./PaxHeaders.21352/elk-6.3.2 0000644 0000000 0000000 00000000132 13543334761 012117 x ustar 00 30 mtime=1569569265.604628548
30 atime=1569569199.886670523
30 ctime=1569569265.604628548
elk-6.3.2/ 0000755 0025044 0025044 00000000000 13543334761 014106 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/PaxHeaders.21352/src 0000644 0000000 0000000 00000000132 13543334737 012554 x ustar 00 30 mtime=1569569247.304640236
30 atime=1569569237.958646206
30 ctime=1569569247.304640236
elk-6.3.2/src/ 0000755 0025044 0025044 00000000000 13543334737 014700 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/src/PaxHeaders.21352/BLAS 0000644 0000000 0000000 00000000130 13543334726 013271 x ustar 00 30 mtime=1569569238.223646036
28 atime=1569569237.9666462
30 ctime=1569569238.223646036
elk-6.3.2/src/BLAS/ 0000755 0025044 0025044 00000000000 13543334726 015417 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/src/BLAS/PaxHeaders.21352/Makefile 0000644 0000000 0000000 00000000130 13543334725 015005 x ustar 00 30 mtime=1569569237.968646199
28 atime=1569569237.9676462
30 ctime=1569569237.968646199
elk-6.3.2/src/BLAS/Makefile 0000644 0025044 0025044 00000002152 13543334725 017056 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 = \
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 zher.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-6.3.2/src/BLAS/PaxHeaders.21352/zgemv.f 0000644 0000000 0000000 00000000132 13543334725 014646 x ustar 00 30 mtime=1569569237.973646196
30 atime=1569569237.972646197
30 ctime=1569569237.973646196
elk-6.3.2/src/BLAS/zgemv.f 0000644 0025044 0025044 00000022240 13543334725 016715 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-6.3.2/src/BLAS/PaxHeaders.21352/dcabs1.f 0000644 0000000 0000000 00000000132 13543334725 014653 x ustar 00 30 mtime=1569569237.977646193
30 atime=1569569237.976646194
30 ctime=1569569237.977646193
elk-6.3.2/src/BLAS/dcabs1.f 0000644 0025044 0025044 00000002565 13543334725 016732 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-6.3.2/src/BLAS/PaxHeaders.21352/dspmv.f 0000644 0000000 0000000 00000000130 13543334725 014645 x ustar 00 29 mtime=1569569237.98264619
30 atime=1569569237.981646191
29 ctime=1569569237.98264619
elk-6.3.2/src/BLAS/dspmv.f 0000644 0025044 0025044 00000022372 13543334725 016724 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-6.3.2/src/BLAS/PaxHeaders.21352/dspr2.f 0000644 0000000 0000000 00000000132 13543334725 014550 x ustar 00 30 mtime=1569569237.987646187
30 atime=1569569237.985646188
30 ctime=1569569237.987646187
elk-6.3.2/src/BLAS/dspr2.f 0000644 0025044 0025044 00000020646 13543334725 016627 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-6.3.2/src/BLAS/PaxHeaders.21352/zgeru.f 0000644 0000000 0000000 00000000132 13543334725 014652 x ustar 00 30 mtime=1569569237.991646185
30 atime=1569569237.990646185
30 ctime=1569569237.991646185
elk-6.3.2/src/BLAS/zgeru.f 0000644 0025044 0025044 00000013020 13543334725 016715 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-6.3.2/src/BLAS/PaxHeaders.21352/ztbsv.f 0000644 0000000 0000000 00000000132 13543334725 014666 x ustar 00 30 mtime=1569569237.996646181
30 atime=1569569237.994646183
30 ctime=1569569237.996646181
elk-6.3.2/src/BLAS/ztbsv.f 0000644 0025044 0025044 00000033516 13543334725 016745 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-6.3.2/src/BLAS/PaxHeaders.21352/zgemm.f 0000644 0000000 0000000 00000000132 13543334726 014636 x ustar 00 30 mtime=1569569238.002646177
30 atime=1569569238.000646179
30 ctime=1569569238.002646177
elk-6.3.2/src/BLAS/zgemm.f 0000644 0025044 0025044 00000033775 13543334726 016724 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-6.3.2/src/BLAS/PaxHeaders.21352/daxpy.f 0000644 0000000 0000000 00000000132 13543334726 014644 x ustar 00 30 mtime=1569569238.006646175
30 atime=1569569238.005646176
30 ctime=1569569238.006646175
elk-6.3.2/src/BLAS/daxpy.f 0000644 0025044 0025044 00000006645 13543334726 016726 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-6.3.2/src/BLAS/PaxHeaders.21352/dcopy.f 0000644 0000000 0000000 00000000132 13543334726 014635 x ustar 00 30 mtime=1569569238.010646172
30 atime=1569569238.009646173
30 ctime=1569569238.010646172
elk-6.3.2/src/BLAS/dcopy.f 0000644 0025044 0025044 00000006323 13543334726 016710 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-6.3.2/src/BLAS/PaxHeaders.21352/zdotc.f 0000644 0000000 0000000 00000000127 13543334726 014646 x ustar 00 29 mtime=1569569238.01464617
29 atime=1569569238.01364617
29 ctime=1569569238.01464617
elk-6.3.2/src/BLAS/zdotc.f 0000644 0025044 0025044 00000005644 13543334726 016722 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-6.3.2/src/BLAS/PaxHeaders.21352/zhemv.f 0000644 0000000 0000000 00000000132 13543334726 014650 x ustar 00 30 mtime=1569569238.019646167
30 atime=1569569238.018646167
30 ctime=1569569238.019646167
elk-6.3.2/src/BLAS/zhemv.f 0000644 0025044 0025044 00000022554 13543334726 016727 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-6.3.2/src/BLAS/PaxHeaders.21352/zaxpy.f 0000644 0000000 0000000 00000000132 13543334726 014672 x ustar 00 30 mtime=1569569238.023646164
30 atime=1569569238.022646165
30 ctime=1569569238.023646164
elk-6.3.2/src/BLAS/zaxpy.f 0000644 0025044 0025044 00000006004 13543334726 016741 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-6.3.2/src/BLAS/PaxHeaders.21352/zdotu.f 0000644 0000000 0000000 00000000132 13543334726 014664 x ustar 00 30 mtime=1569569238.027646162
30 atime=1569569238.026646162
30 ctime=1569569238.027646162
elk-6.3.2/src/BLAS/zdotu.f 0000644 0025044 0025044 00000005524 13543334726 016741 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-6.3.2/src/BLAS/PaxHeaders.21352/zcopy.f 0000644 0000000 0000000 00000000132 13543334726 014663 x ustar 00 30 mtime=1569569238.032646158
30 atime=1569569238.031646159
30 ctime=1569569238.032646158
elk-6.3.2/src/BLAS/zcopy.f 0000644 0025044 0025044 00000005266 13543334726 016743 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-6.3.2/src/BLAS/PaxHeaders.21352/dscal.f 0000644 0000000 0000000 00000000132 13543334726 014605 x ustar 00 30 mtime=1569569238.036646156
30 atime=1569569238.035646156
30 ctime=1569569238.036646156
elk-6.3.2/src/BLAS/dscal.f 0000644 0025044 0025044 00000005664 13543334726 016667 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-6.3.2/src/BLAS/PaxHeaders.21352/dnrm2.f 0000644 0000000 0000000 00000000132 13543334726 014541 x ustar 00 30 mtime=1569569238.040646153
30 atime=1569569238.039646154
30 ctime=1569569238.040646153
elk-6.3.2/src/BLAS/dnrm2.f 0000644 0025044 0025044 00000006001 13543334726 016605 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-6.3.2/src/BLAS/PaxHeaders.21352/ddot.f 0000644 0000000 0000000 00000000130 13543334726 014447 x ustar 00 29 mtime=1569569238.04564615
30 atime=1569569238.044646151
29 ctime=1569569238.04564615
elk-6.3.2/src/BLAS/ddot.f 0000644 0025044 0025044 00000006523 13543334726 016526 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-6.3.2/src/BLAS/PaxHeaders.21352/zher.f 0000644 0000000 0000000 00000000132 13543334726 014467 x ustar 00 30 mtime=1569569238.049646148
30 atime=1569569238.048646148
30 ctime=1569569238.049646148
elk-6.3.2/src/BLAS/zher.f 0000644 0025044 0025044 00000017504 13543334726 016545 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHER
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER INCX,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHER 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.
*> \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 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] 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 ZHER(UPLO,N,ALPHA,X,INCX,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,LDA,N
CHARACTER 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
* ..
* .. 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 (LDA.LT.MAX(1,N)) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZHER ',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 A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in upper triangle.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(J))
DO 10 I = 1,J - 1
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
A(J,J) = DBLE(A(J,J)) + DBLE(X(J)*TEMP)
ELSE
A(J,J) = DBLE(A(J,J))
END IF
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 I = 1,J - 1
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
A(J,J) = DBLE(A(J,J)) + DBLE(X(JX)*TEMP)
ELSE
A(J,J) = DBLE(A(J,J))
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in lower triangle.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(J))
A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(J))
DO 50 I = J + 1,N
A(I,J) = A(I,J) + X(I)*TEMP
50 CONTINUE
ELSE
A(J,J) = DBLE(A(J,J))
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(JX))
A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(JX))
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
A(I,J) = A(I,J) + X(IX)*TEMP
70 CONTINUE
ELSE
A(J,J) = DBLE(A(J,J))
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHER .
*
END
elk-6.3.2/src/BLAS/PaxHeaders.21352/zdscal.f 0000644 0000000 0000000 00000000132 13543334726 014777 x ustar 00 30 mtime=1569569238.054646144
30 atime=1569569238.053646145
30 ctime=1569569238.054646144
elk-6.3.2/src/BLAS/zdscal.f 0000644 0025044 0025044 00000005044 13543334726 017051 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-6.3.2/src/BLAS/PaxHeaders.21352/dgemm.f 0000644 0000000 0000000 00000000132 13543334726 014610 x ustar 00 30 mtime=1569569238.059646141
30 atime=1569569238.057646142
30 ctime=1569569238.059646141
elk-6.3.2/src/BLAS/dgemm.f 0000644 0025044 0025044 00000025557 13543334726 016675 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-6.3.2/src/BLAS/PaxHeaders.21352/dznrm2.f 0000644 0000000 0000000 00000000132 13543334726 014733 x ustar 00 30 mtime=1569569238.063646139
30 atime=1569569238.062646139
30 ctime=1569569238.063646139
elk-6.3.2/src/BLAS/dznrm2.f 0000644 0025044 0025044 00000006464 13543334726 017014 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-6.3.2/src/BLAS/PaxHeaders.21352/idamax.f 0000644 0000000 0000000 00000000132 13543334726 014762 x ustar 00 30 mtime=1569569238.067646136
30 atime=1569569238.066646137
30 ctime=1569569238.067646136
elk-6.3.2/src/BLAS/idamax.f 0000644 0025044 0025044 00000005343 13543334726 017036 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 SX
*> \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-6.3.2/src/BLAS/PaxHeaders.21352/dtrsm.f 0000644 0000000 0000000 00000000132 13543334726 014650 x ustar 00 30 mtime=1569569238.073646132
30 atime=1569569238.071646133
30 ctime=1569569238.073646132
elk-6.3.2/src/BLAS/dtrsm.f 0000644 0025044 0025044 00000032734 13543334726 016730 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-6.3.2/src/BLAS/PaxHeaders.21352/dgemv.f 0000644 0000000 0000000 00000000127 13543334726 014625 x ustar 00 29 mtime=1569569238.07764613
29 atime=1569569238.07664613
29 ctime=1569569238.07764613
elk-6.3.2/src/BLAS/dgemv.f 0000644 0025044 0025044 00000021073 13543334726 016673 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-6.3.2/src/BLAS/PaxHeaders.21352/dswap.f 0000644 0000000 0000000 00000000132 13543334726 014635 x ustar 00 30 mtime=1569569238.082646126
30 atime=1569569238.081646127
30 ctime=1569569238.082646126
elk-6.3.2/src/BLAS/dswap.f 0000644 0025044 0025044 00000006605 13543334726 016713 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-6.3.2/src/BLAS/PaxHeaders.21352/lsame.f 0000644 0000000 0000000 00000000132 13543334726 014620 x ustar 00 30 mtime=1569569238.086646124
30 atime=1569569238.085646125
30 ctime=1569569238.086646124
elk-6.3.2/src/BLAS/lsame.f 0000644 0025044 0025044 00000006101 13543334726 016665 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-6.3.2/src/BLAS/PaxHeaders.21352/drot.f 0000644 0000000 0000000 00000000132 13543334726 014467 x ustar 00 30 mtime=1569569238.090646121
30 atime=1569569238.089646122
30 ctime=1569569238.090646121
elk-6.3.2/src/BLAS/drot.f 0000644 0025044 0025044 00000006140 13543334726 016537 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-6.3.2/src/BLAS/PaxHeaders.21352/dtrmm.f 0000644 0000000 0000000 00000000132 13543334726 014642 x ustar 00 30 mtime=1569569238.095646118
30 atime=1569569238.094646119
30 ctime=1569569238.095646118
elk-6.3.2/src/BLAS/dtrmm.f 0000644 0025044 0025044 00000031007 13543334726 016712 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-6.3.2/src/BLAS/PaxHeaders.21352/dger.f 0000644 0000000 0000000 00000000132 13543334726 014440 x ustar 00 30 mtime=1569569238.100646115
30 atime=1569569238.099646116
30 ctime=1569569238.100646115
elk-6.3.2/src/BLAS/dger.f 0000644 0025044 0025044 00000013075 13543334726 016515 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-6.3.2/src/BLAS/PaxHeaders.21352/dtrmv.f 0000644 0000000 0000000 00000000132 13543334726 014653 x ustar 00 30 mtime=1569569238.105646112
30 atime=1569569238.103646113
30 ctime=1569569238.105646112
elk-6.3.2/src/BLAS/dtrmv.f 0000644 0025044 0025044 00000023620 13543334726 016725 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-6.3.2/src/BLAS/PaxHeaders.21352/dsymv.f 0000644 0000000 0000000 00000000131 13543334726 014660 x ustar 00 30 mtime=1569569238.110646109
29 atime=1569569238.10864611
30 ctime=1569569238.110646109
elk-6.3.2/src/BLAS/dsymv.f 0000644 0025044 0025044 00000022265 13543334726 016737 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-6.3.2/src/BLAS/PaxHeaders.21352/dsyrk.f 0000644 0000000 0000000 00000000132 13543334726 014653 x ustar 00 30 mtime=1569569238.114646106
30 atime=1569569238.113646107
30 ctime=1569569238.114646106
elk-6.3.2/src/BLAS/dsyrk.f 0000644 0025044 0025044 00000025056 13543334726 016732 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-6.3.2/src/BLAS/PaxHeaders.21352/dsyr2.f 0000644 0000000 0000000 00000000132 13543334726 014562 x ustar 00 30 mtime=1569569238.119646103
30 atime=1569569238.118646103
30 ctime=1569569238.119646103
elk-6.3.2/src/BLAS/dsyr2.f 0000644 0025044 0025044 00000020622 13543334726 016633 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-6.3.2/src/BLAS/PaxHeaders.21352/dtrsv.f 0000644 0000000 0000000 00000000124 13543334726 014662 x ustar 00 28 mtime=1569569238.1246461
28 atime=1569569238.1236461
28 ctime=1569569238.1246461
elk-6.3.2/src/BLAS/dtrsv.f 0000644 0025044 0025044 00000023614 13543334726 016736 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-6.3.2/src/BLAS/PaxHeaders.21352/dsymm.f 0000644 0000000 0000000 00000000132 13543334726 014650 x ustar 00 30 mtime=1569569238.129646096
30 atime=1569569238.127646098
30 ctime=1569569238.129646096
elk-6.3.2/src/BLAS/dsymm.f 0000644 0025044 0025044 00000025655 13543334726 016734 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-6.3.2/src/BLAS/PaxHeaders.21352/dsyr2k.f 0000644 0000000 0000000 00000000132 13543334726 014735 x ustar 00 30 mtime=1569569238.134646093
30 atime=1569569238.132646095
30 ctime=1569569238.134646093
elk-6.3.2/src/BLAS/dsyr2k.f 0000644 0025044 0025044 00000030316 13543334726 017007 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-6.3.2/src/BLAS/PaxHeaders.21352/zswap.f 0000644 0000000 0000000 00000000132 13543334726 014663 x ustar 00 30 mtime=1569569238.138646091
30 atime=1569569238.137646091
30 ctime=1569569238.138646091
elk-6.3.2/src/BLAS/zswap.f 0000644 0025044 0025044 00000005450 13543334726 016736 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-6.3.2/src/BLAS/PaxHeaders.21352/izamax.f 0000644 0000000 0000000 00000000132 13543334726 015010 x ustar 00 30 mtime=1569569238.143646088
30 atime=1569569238.142646088
30 ctime=1569569238.143646088
elk-6.3.2/src/BLAS/izamax.f 0000644 0025044 0025044 00000005364 13543334726 017067 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 SX
*> \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-6.3.2/src/BLAS/PaxHeaders.21352/zscal.f 0000644 0000000 0000000 00000000132 13543334726 014633 x ustar 00 30 mtime=1569569238.147646085
30 atime=1569569238.146646086
30 ctime=1569569238.147646085
elk-6.3.2/src/BLAS/zscal.f 0000644 0025044 0025044 00000004662 13543334726 016712 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-6.3.2/src/BLAS/PaxHeaders.21352/ztrmm.f 0000644 0000000 0000000 00000000132 13543334726 014670 x ustar 00 30 mtime=1569569238.152646082
30 atime=1569569238.150646083
30 ctime=1569569238.152646082
elk-6.3.2/src/BLAS/ztrmm.f 0000644 0025044 0025044 00000034166 13543334726 016751 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-6.3.2/src/BLAS/PaxHeaders.21352/ztrsm.f 0000644 0000000 0000000 00000000132 13543334726 014676 x ustar 00 30 mtime=1569569238.158646078
30 atime=1569569238.156646079
30 ctime=1569569238.158646078
elk-6.3.2/src/BLAS/ztrsm.f 0000644 0025044 0025044 00000035747 13543334726 016765 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-6.3.2/src/BLAS/PaxHeaders.21352/zher2.f 0000644 0000000 0000000 00000000132 13543334726 014551 x ustar 00 30 mtime=1569569238.162646075
30 atime=1569569238.161646076
30 ctime=1569569238.162646075
elk-6.3.2/src/BLAS/zher2.f 0000644 0025044 0025044 00000022451 13543334726 016624 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-6.3.2/src/BLAS/PaxHeaders.21352/ztrsv.f 0000644 0000000 0000000 00000000132 13543334726 014707 x ustar 00 30 mtime=1569569238.167646072
30 atime=1569569238.166646073
30 ctime=1569569238.167646072
elk-6.3.2/src/BLAS/ztrsv.f 0000644 0025044 0025044 00000026615 13543334726 016770 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-6.3.2/src/BLAS/PaxHeaders.21352/ztrmv.f 0000644 0000000 0000000 00000000131 13543334726 014700 x ustar 00 30 mtime=1569569238.172646069
29 atime=1569569238.17064607
30 ctime=1569569238.172646069
elk-6.3.2/src/BLAS/ztrmv.f 0000644 0025044 0025044 00000026467 13543334726 016767 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-6.3.2/src/BLAS/PaxHeaders.21352/zhemm.f 0000644 0000000 0000000 00000000132 13543334726 014637 x ustar 00 30 mtime=1569569238.177646066
30 atime=1569569238.176646067
30 ctime=1569569238.177646066
elk-6.3.2/src/BLAS/zhemm.f 0000644 0025044 0025044 00000026153 13543334726 016715 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-6.3.2/src/BLAS/PaxHeaders.21352/zher2k.f 0000644 0000000 0000000 00000000132 13543334726 014724 x ustar 00 30 mtime=1569569238.183646062
30 atime=1569569238.181646063
30 ctime=1569569238.183646062
elk-6.3.2/src/BLAS/zher2k.f 0000644 0025044 0025044 00000034530 13543334726 017000 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-6.3.2/src/BLAS/PaxHeaders.21352/ztpsv.f 0000644 0000000 0000000 00000000131 13543334726 014704 x ustar 00 30 mtime=1569569238.188646059
29 atime=1569569238.18664606
30 ctime=1569569238.188646059
elk-6.3.2/src/BLAS/ztpsv.f 0000644 0025044 0025044 00000030117 13543334726 016756 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-6.3.2/src/BLAS/PaxHeaders.21352/zhpmv.f 0000644 0000000 0000000 00000000132 13543334726 014663 x ustar 00 30 mtime=1569569238.193646056
30 atime=1569569238.191646057
30 ctime=1569569238.193646056
elk-6.3.2/src/BLAS/zhpmv.f 0000644 0025044 0025044 00000022752 13543334726 016742 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-6.3.2/src/BLAS/PaxHeaders.21352/zhpr2.f 0000644 0000000 0000000 00000000132 13543334726 014564 x ustar 00 30 mtime=1569569238.197646053
30 atime=1569569238.196646054
30 ctime=1569569238.197646053
elk-6.3.2/src/BLAS/zhpr2.f 0000644 0025044 0025044 00000022636 13543334726 016644 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-6.3.2/src/BLAS/PaxHeaders.21352/ztpmv.f 0000644 0000000 0000000 00000000130 13543334726 014675 x ustar 00 29 mtime=1569569238.20264605
30 atime=1569569238.200646051
29 ctime=1569569238.20264605
elk-6.3.2/src/BLAS/ztpmv.f 0000644 0025044 0025044 00000027752 13543334726 016763 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-6.3.2/src/BLAS/PaxHeaders.21352/zdrot.f 0000644 0000000 0000000 00000000132 13543334726 014661 x ustar 00 30 mtime=1569569238.207646047
30 atime=1569569238.205646048
30 ctime=1569569238.207646047
elk-6.3.2/src/BLAS/zdrot.f 0000644 0025044 0025044 00000007532 13543334726 016737 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-6.3.2/src/BLAS/PaxHeaders.21352/zgerc.f 0000644 0000000 0000000 00000000132 13543334726 014631 x ustar 00 30 mtime=1569569238.211646044
30 atime=1569569238.210646045
30 ctime=1569569238.211646044
elk-6.3.2/src/BLAS/zgerc.f 0000644 0025044 0025044 00000013047 13543334726 016705 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-6.3.2/src/BLAS/PaxHeaders.21352/dzasum.f 0000644 0000000 0000000 00000000132 13543334726 015022 x ustar 00 30 mtime=1569569238.215646042
30 atime=1569569238.214646042
30 ctime=1569569238.215646042
elk-6.3.2/src/BLAS/dzasum.f 0000644 0025044 0025044 00000005073 13543334726 017076 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-6.3.2/src/BLAS/PaxHeaders.21352/zherk.f 0000644 0000000 0000000 00000000132 13543334726 014642 x ustar 00 30 mtime=1569569238.220646038
30 atime=1569569238.219646039
30 ctime=1569569238.220646038
elk-6.3.2/src/BLAS/zherk.f 0000644 0025044 0025044 00000027702 13543334726 016721 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-6.3.2/src/BLAS/PaxHeaders.21352/zhpr.f 0000644 0000000 0000000 00000000132 13543334726 014502 x ustar 00 30 mtime=1569569238.225646035
30 atime=1569569238.224646036
30 ctime=1569569238.225646035
elk-6.3.2/src/BLAS/zhpr.f 0000644 0025044 0025044 00000017672 13543334726 016566 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-6.3.2/src/PaxHeaders.21352/LAPACK 0000644 0000000 0000000 00000000132 13543334727 013506 x ustar 00 30 mtime=1569569239.523645206
30 atime=1569569238.235646029
30 ctime=1569569239.523645206
elk-6.3.2/src/LAPACK/ 0000755 0025044 0025044 00000000000 13543334727 015632 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed5.f 0000644 0000000 0000000 00000000132 13543334726 015067 x ustar 00 30 mtime=1569569238.238646027
30 atime=1569569238.237646028
30 ctime=1569569238.238646027
elk-6.3.2/src/LAPACK/dlaed5.f 0000644 0025044 0025044 00000012373 13543334726 017144 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-6.3.2/src/LAPACK/PaxHeaders.21352/disnan.f 0000644 0000000 0000000 00000000132 13543334726 015205 x ustar 00 30 mtime=1569569238.242646024
30 atime=1569569238.241646025
30 ctime=1569569238.242646024
elk-6.3.2/src/LAPACK/disnan.f 0000644 0025044 0025044 00000003727 13543334726 017265 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed1.f 0000644 0000000 0000000 00000000132 13543334726 015063 x ustar 00 30 mtime=1569569238.246646022
30 atime=1569569238.245646022
30 ctime=1569569238.246646022
elk-6.3.2/src/LAPACK/dlaed1.f 0000644 0025044 0025044 00000020435 13543334726 017136 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlamch.f 0000644 0000000 0000000 00000000131 13543334726 015160 x ustar 00 30 mtime=1569569238.250646019
29 atime=1569569238.24964602
30 ctime=1569569238.250646019
elk-6.3.2/src/LAPACK/dlamch.f 0000644 0025044 0025044 00000006723 13543334726 017240 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhpgvx.f 0000644 0000000 0000000 00000000132 13543334726 015257 x ustar 00 30 mtime=1569569238.255646016
30 atime=1569569238.253646017
30 ctime=1569569238.255646016
elk-6.3.2/src/LAPACK/zhpgvx.f 0000644 0025044 0025044 00000032214 13543334726 017330 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-6.3.2/src/LAPACK/PaxHeaders.21352/iparam2stage.f 0000644 0000000 0000000 00000000132 13543334726 016310 x ustar 00 30 mtime=1569569238.260646013
30 atime=1569569238.258646014
30 ctime=1569569238.260646013
elk-6.3.2/src/LAPACK/iparam2stage.f 0000644 0025044 0025044 00000030004 13543334726 020354 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_H@2HB, 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed2.f 0000644 0000000 0000000 00000000130 13543334726 015062 x ustar 00 29 mtime=1569569238.26564601
30 atime=1569569238.263646011
29 ctime=1569569238.26564601
elk-6.3.2/src/LAPACK/dlaed2.f 0000644 0025044 0025044 00000037231 13543334726 017141 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhegv.f 0000644 0000000 0000000 00000000132 13543334726 015054 x ustar 00 30 mtime=1569569238.269646007
30 atime=1569569238.267646008
30 ctime=1569569238.269646007
elk-6.3.2/src/LAPACK/zhegv.f 0000644 0025044 0025044 00000023067 13543334726 017133 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgetrf.f 0000644 0000000 0000000 00000000132 13543334726 015232 x ustar 00 30 mtime=1569569238.273646005
30 atime=1569569238.272646005
30 ctime=1569569238.273646005
elk-6.3.2/src/LAPACK/zgetrf.f 0000644 0025044 0025044 00000014237 13543334726 017310 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgetri.f 0000644 0000000 0000000 00000000132 13543334726 015235 x ustar 00 30 mtime=1569569238.277646002
30 atime=1569569238.276646003
30 ctime=1569569238.277646002
elk-6.3.2/src/LAPACK/zgetri.f 0000644 0025044 0025044 00000016365 13543334726 017317 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgesv.f 0000644 0000000 0000000 00000000127 13543334726 015045 x ustar 00 30 mtime=1569569238.281645999
27 atime=1569569238.280646
30 ctime=1569569238.281645999
elk-6.3.2/src/LAPACK/dgesv.f 0000644 0025044 0025044 00000012027 13543334726 017112 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsyev.f 0000644 0000000 0000000 00000000132 13543334726 015063 x ustar 00 30 mtime=1569569238.286645996
30 atime=1569569238.284645997
30 ctime=1569569238.286645996
elk-6.3.2/src/LAPACK/dsyev.f 0000644 0025044 0025044 00000020364 13543334726 017137 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsygvx.f 0000644 0000000 0000000 00000000132 13543334726 015255 x ustar 00 30 mtime=1569569238.291645993
30 atime=1569569238.289645994
30 ctime=1569569238.291645993
elk-6.3.2/src/LAPACK/dsygvx.f 0000644 0025044 0025044 00000035561 13543334726 017336 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhegvx.f 0000644 0000000 0000000 00000000130 13543334726 015242 x ustar 00 29 mtime=1569569238.29664599
30 atime=1569569238.294645991
29 ctime=1569569238.29664599
elk-6.3.2/src/LAPACK/zhegvx.f 0000644 0025044 0025044 00000036064 13543334726 017324 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-6.3.2/src/LAPACK/PaxHeaders.21352/zheevd.f 0000644 0000000 0000000 00000000132 13543334726 015216 x ustar 00 30 mtime=1569569238.301645987
30 atime=1569569238.299645988
30 ctime=1569569238.301645987
elk-6.3.2/src/LAPACK/zheevd.f 0000644 0025044 0025044 00000031337 13543334726 017274 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-6.3.2/src/LAPACK/PaxHeaders.21352/zheev.f 0000644 0000000 0000000 00000000132 13543334726 015052 x ustar 00 30 mtime=1569569238.305645984
30 atime=1569569238.304645985
30 ctime=1569569238.305645984
elk-6.3.2/src/LAPACK/zheev.f 0000644 0025044 0025044 00000021146 13543334726 017125 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgetrf.f 0000644 0000000 0000000 00000000132 13543334726 015204 x ustar 00 30 mtime=1569569238.309645982
30 atime=1569569238.308645982
30 ctime=1569569238.309645982
elk-6.3.2/src/LAPACK/dgetrf.f 0000644 0025044 0025044 00000014226 13543334726 017260 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgetri.f 0000644 0000000 0000000 00000000131 13543334726 015206 x ustar 00 30 mtime=1569569238.313645979
29 atime=1569569238.31264598
30 ctime=1569569238.313645979
elk-6.3.2/src/LAPACK/dgetri.f 0000644 0025044 0025044 00000016315 13543334726 017264 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgesv.f 0000644 0000000 0000000 00000000132 13543334726 015067 x ustar 00 30 mtime=1569569238.318645976
30 atime=1569569238.316645977
30 ctime=1569569238.318645976
elk-6.3.2/src/LAPACK/zgesv.f 0000644 0025044 0025044 00000012032 13543334726 017134 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgeev.f 0000644 0000000 0000000 00000000132 13543334726 015051 x ustar 00 30 mtime=1569569238.323645973
30 atime=1569569238.321645974
30 ctime=1569569238.323645973
elk-6.3.2/src/LAPACK/zgeev.f 0000644 0025044 0025044 00000037302 13543334726 017125 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 and i+1:N of W contain eigenvalues which have
*> converged.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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-6.3.2/src/LAPACK/PaxHeaders.21352/ilaenv.f 0000644 0000000 0000000 00000000132 13543334726 015207 x ustar 00 30 mtime=1569569238.328645969
30 atime=1569569238.326645971
30 ctime=1569569238.328645969
elk-6.3.2/src/LAPACK/ilaenv.f 0000644 0025044 0025044 00000050217 13543334726 017263 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 2017
*
*> \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.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*( * ) 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( 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-6.3.2/src/LAPACK/PaxHeaders.21352/xerbla.f 0000644 0000000 0000000 00000000132 13543334726 015206 x ustar 00 30 mtime=1569569238.332645967
30 atime=1569569238.331645967
30 ctime=1569569238.332645967
elk-6.3.2/src/LAPACK/xerbla.f 0000644 0025044 0025044 00000005031 13543334726 017254 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-6.3.2/src/LAPACK/PaxHeaders.21352/zpptrf.f 0000644 0000000 0000000 00000000132 13543334726 015256 x ustar 00 30 mtime=1569569238.337645964
30 atime=1569569238.335645965
30 ctime=1569569238.337645964
elk-6.3.2/src/LAPACK/zpptrf.f 0000644 0025044 0025044 00000014476 13543334726 017341 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhpgst.f 0000644 0000000 0000000 00000000132 13543334726 015250 x ustar 00 30 mtime=1569569238.341645961
30 atime=1569569238.340645962
30 ctime=1569569238.341645961
elk-6.3.2/src/LAPACK/zhpgst.f 0000644 0025044 0025044 00000020542 13543334726 017322 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhpevx.f 0000644 0000000 0000000 00000000132 13543334726 015255 x ustar 00 30 mtime=1569569238.346645958
30 atime=1569569238.344645959
30 ctime=1569569238.346645958
elk-6.3.2/src/LAPACK/zhpevx.f 0000644 0025044 0025044 00000037627 13543334726 017343 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgetrs.f 0000644 0000000 0000000 00000000132 13543334726 015221 x ustar 00 30 mtime=1569569238.351645955
30 atime=1569569238.349645956
30 ctime=1569569238.351645955
elk-6.3.2/src/LAPACK/dgetrs.f 0000644 0025044 0025044 00000013564 13543334726 017301 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgetrf2.f 0000644 0000000 0000000 00000000132 13543334726 015266 x ustar 00 30 mtime=1569569238.355645952
30 atime=1569569238.354645953
30 ctime=1569569238.355645952
elk-6.3.2/src/LAPACK/dgetrf2.f 0000644 0025044 0025044 00000015602 13543334726 017341 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaswp.f 0000644 0000000 0000000 00000000127 13543334726 015227 x ustar 00 29 mtime=1569569238.35964595
29 atime=1569569238.35864595
29 ctime=1569569238.35964595
elk-6.3.2/src/LAPACK/dlaswp.f 0000644 0025044 0025044 00000012010 13543334726 017264 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-6.3.2/src/LAPACK/PaxHeaders.21352/dtrtri.f 0000644 0000000 0000000 00000000132 13543334726 015241 x ustar 00 30 mtime=1569569238.364645946
30 atime=1569569238.362645948
30 ctime=1569569238.364645946
elk-6.3.2/src/LAPACK/dtrtri.f 0000644 0025044 0025044 00000015367 13543334726 017324 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlansy.f 0000644 0000000 0000000 00000000132 13543334726 015223 x ustar 00 30 mtime=1569569238.368645944
30 atime=1569569238.366645945
30 ctime=1569569238.368645944
elk-6.3.2/src/LAPACK/dlansy.f 0000644 0025044 0025044 00000016317 13543334726 017302 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
*
* .. 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, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( A( J, J ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( A( J, J ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
CALL DLASSQ( N, A, LDA+1, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANSY = VALUE
RETURN
*
* End of DLANSY
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlascl.f 0000644 0000000 0000000 00000000132 13543334726 015173 x ustar 00 30 mtime=1569569238.372645941
30 atime=1569569238.371645942
30 ctime=1569569238.372645941
elk-6.3.2/src/LAPACK/dlascl.f 0000644 0025044 0025044 00000023427 13543334726 017252 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsytrd.f 0000644 0000000 0000000 00000000132 13543334726 015242 x ustar 00 30 mtime=1569569238.377645938
30 atime=1569569238.375645939
30 ctime=1569569238.377645938
elk-6.3.2/src/LAPACK/dsytrd.f 0000644 0025044 0025044 00000026346 13543334726 017324 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsterf.f 0000644 0000000 0000000 00000000132 13543334726 015220 x ustar 00 30 mtime=1569569238.381645936
30 atime=1569569238.380645936
30 ctime=1569569238.381645936
elk-6.3.2/src/LAPACK/dsterf.f 0000644 0025044 0025044 00000024631 13543334726 017275 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorgtr.f 0000644 0000000 0000000 00000000132 13543334726 015232 x ustar 00 30 mtime=1569569238.386645932
30 atime=1569569238.385645933
30 ctime=1569569238.386645932
elk-6.3.2/src/LAPACK/dorgtr.f 0000644 0025044 0025044 00000015620 13543334726 017305 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsteqr.f 0000644 0000000 0000000 00000000131 13543334726 015232 x ustar 00 30 mtime=1569569238.391645929
29 atime=1569569238.38964593
30 ctime=1569569238.391645929
elk-6.3.2/src/LAPACK/dsteqr.f 0000644 0025044 0025044 00000036276 13543334726 017320 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-6.3.2/src/LAPACK/PaxHeaders.21352/dpotrf.f 0000644 0000000 0000000 00000000132 13543334726 015227 x ustar 00 30 mtime=1569569238.395645927
30 atime=1569569238.394645927
30 ctime=1569569238.395645927
elk-6.3.2/src/LAPACK/dpotrf.f 0000644 0025044 0025044 00000016046 13543334726 017305 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsygst.f 0000644 0000000 0000000 00000000132 13543334726 015246 x ustar 00 30 mtime=1569569238.400645923
30 atime=1569569238.398645925
30 ctime=1569569238.400645923
elk-6.3.2/src/LAPACK/dsygst.f 0000644 0025044 0025044 00000025360 13543334726 017323 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsyevx.f 0000644 0000000 0000000 00000000130 13543334726 015251 x ustar 00 29 mtime=1569569238.40564592
30 atime=1569569238.403645921
29 ctime=1569569238.40564592
elk-6.3.2/src/LAPACK/dsyevx.f 0000644 0025044 0025044 00000042616 13543334726 017333 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-6.3.2/src/LAPACK/PaxHeaders.21352/ieeeck.f 0000644 0000000 0000000 00000000132 13543334726 015156 x ustar 00 30 mtime=1569569238.409645918
30 atime=1569569238.408645918
30 ctime=1569569238.409645918
elk-6.3.2/src/LAPACK/ieeeck.f 0000644 0025044 0025044 00000010724 13543334726 017231 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-6.3.2/src/LAPACK/PaxHeaders.21352/iparmq.f 0000644 0000000 0000000 00000000132 13543334726 015222 x ustar 00 30 mtime=1569569238.414645914
30 atime=1569569238.412645916
30 ctime=1569569238.414645914
elk-6.3.2/src/LAPACK/iparmq.f 0000644 0025044 0025044 00000033430 13543334726 017274 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.GT.(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).LE.500 is NS. The default
*> for (IHI-ILO+1).GT.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-6.3.2/src/LAPACK/PaxHeaders.21352/ztrevc3.f 0000644 0000000 0000000 00000000132 13543334726 015331 x ustar 00 30 mtime=1569569238.419645911
30 atime=1569569238.417645913
30 ctime=1569569238.419645911
elk-6.3.2/src/LAPACK/ztrevc3.f 0000644 0025044 0025044 00000051237 13543334726 017410 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhseqr.f 0000644 0000000 0000000 00000000132 13543334726 015245 x ustar 00 30 mtime=1569569238.425645907
30 atime=1569569238.422645909
30 ctime=1569569238.425645907
elk-6.3.2/src/LAPACK/zhseqr.f 0000644 0025044 0025044 00000043030 13543334726 017314 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 .GE. 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL, and then passed to ZGEHRD
*> when the matrix output by ZGEBAL is reduced to Hessenberg
*> form. Otherwise ILO and IHI should be set to 1 and N
*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and JOB = 'S', H contains the upper
*> triangular matrix T from the Schur decomposition (the
*> Schur form). If INFO = 0 and JOB = 'E', the contents of
*> H are unspecified on exit. (The output value of H when
*> INFO.GT.0 is given under the description of INFO below.)
*>
*> Unlike earlier versions of ZHSEQR, this subroutine may
*> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
*> or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH .GE. max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues. If JOB = 'S', the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> If COMPZ = 'N', Z is not referenced.
*> If COMPZ = 'I', on entry Z need not be set and on exit,
*> if INFO = 0, Z contains the unitary matrix Z of the Schur
*> vectors of H. If COMPZ = 'V', on entry Z must contain an
*> N-by-N matrix Q, which is assumed to be equal to the unit
*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
*> if INFO = 0, Z contains Q*Z.
*> Normally Q is the unitary matrix generated by ZUNGHR
*> after the call to ZGEHRD which formed the Hessenberg matrix
*> H. (The output value of Z when INFO.GT.0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if COMPZ = 'I' or
*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, if INFO = 0, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK .GE. max(1,N)
*> is sufficient and delivers very good and sometimes
*> optimal performance. However, LWORK as large as 11*N
*> may be required for optimal performance. A workspace
*> query is recommended to determine the optimal workspace
*> size.
*>
*> If LWORK = -1, then ZHSEQR does a workspace query.
*> In this case, ZHSEQR checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .LT. 0: if INFO = -i, the i-th argument had an illegal
*> value
*> .GT. 0: if INFO = i, ZHSEQR failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO .GT. 0 and JOB = 'E', then on exit, the
*> remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO .GT. 0 and JOB = 'S', then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and COMPZ = 'V', then on exit
*>
*> (final value of Z) = (initial value of Z)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of JOB.)
*>
*> If INFO .GT. 0 and COMPZ = 'I', then on exit
*> (final value of Z) = U
*> where U is the unitary matrix in (*) (regard-
*> less of the value of JOB.)
*>
*> If INFO .GT. 0 and COMPZ = 'N', then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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).LE.500 is NS.
*> The default for (IHI-ILO+1).GT.500 is 3*NS/2.
*>
*> ISPEC=14: Nibble crossover point. (See IPARMQ for
*> details.) Default: 14% of deflation window
*> size.
*>
*> ISPEC=15: Number of simultaneous shifts in a multishift
*> QR iteration.
*>
*> If IHI-ILO+1 is ...
*>
*> greater than ...but less ... the
*> or equal to ... than default is
*>
*> 1 30 NS = 2(+)
*> 30 60 NS = 4(+)
*> 60 150 NS = 10(+)
*> 150 590 NS = **
*> 590 3000 NS = 64
*> 3000 6000 NS = 128
*> 6000 infinity NS = 256
*>
*> (+) By default some or all matrices of this order
*> are passed to the implicit double shift routine
*> ZLAHQR and this parameter is ignored. See
*> ISPEC=12 above and comments in IPARMQ for
*> details.
*>
*> (**) The asterisks (**) indicate an ad-hoc
*> function of N increasing from 10 to 64.
*>
*> ISPEC=16: Select structured matrix multiply.
*> If the number of simultaneous shifts (specified
*> by ISPEC=15) is less than 14, then the default
*> for ISPEC=16 is 0. Otherwise the default for
*> ISPEC=16 is 2.
*> \endverbatim
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* =====================================================================
SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.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 .GT. NTINY = 11 is
* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom-
* . mended. (The default value of NMIN is 75.) Using NL = 49
* . allows up to six simultaneous shifts and a 16-by-16
* . deflation window. ====
INTEGER NL
PARAMETER ( NL = 49 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0d0 )
* ..
* .. Local Arrays ..
COMPLEX*16 HL( NL, NL ), WORKL( NL )
* ..
* .. Local Scalars ..
INTEGER KBOT, NMIN
LOGICAL INITZ, LQUERY, WANTT, WANTZ
* ..
* .. External Functions ..
INTEGER ILAENV
LOGICAL LSAME
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, MAX, MIN
* ..
* .. Executable Statements ..
*
* ==== Decode and check the input parameters. ====
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO )
LQUERY = LWORK.EQ.-1
*
INFO = 0
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
*
* ==== Quick return in case of invalid argument. ====
*
CALL XERBLA( 'ZHSEQR', -INFO )
RETURN
*
ELSE IF( N.EQ.0 ) THEN
*
* ==== Quick return in case N = 0; nothing to do. ====
*
RETURN
*
ELSE IF( LQUERY ) THEN
*
* ==== Quick return in case of a workspace query ====
*
CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
$ LDZ, WORK, LWORK, INFO )
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1,
$ N ) ) ), RZERO )
RETURN
*
ELSE
*
* ==== copy eigenvalues isolated by ZGEBAL ====
*
IF( ILO.GT.1 )
$ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 )
IF( IHI.LT.N )
$ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
*
* ==== Initialize Z, if requested ====
*
IF( INITZ )
$ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
*
* ==== Quick return if possible ====
*
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
$ ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
*
IF( N.GT.NMIN ) THEN
CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
$ Z, LDZ, WORK, LWORK, INFO )
ELSE
*
* ==== Small matrix ====
*
CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
$ Z, LDZ, INFO )
*
IF( INFO.GT.0 ) THEN
*
* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds
* . when ZLAHQR fails. ====
*
KBOT = INFO
*
IF( N.GE.NL ) THEN
*
* ==== Larger matrices have enough subdiagonal scratch
* . space to call ZLAQR0 directly. ====
*
CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W,
$ ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
*
ELSE
*
* ==== Tiny matrices don't have enough subdiagonal
* . scratch space to benefit from ZLAQR0. Hence,
* . tiny matrices must be copied into a larger
* . array before calling ZLAQR0. ====
*
CALL ZLACPY( 'A', N, N, H, LDH, HL, NL )
HL( N+1, N ) = ZERO
CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
$ NL )
CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
$ ILO, IHI, Z, LDZ, WORKL, NL, INFO )
IF( WANTT .OR. INFO.NE.0 )
$ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH )
END IF
END IF
END IF
*
* ==== Clear out the trash, if necessary. ====
*
IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
$ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
*
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
*
WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ),
$ DBLE( WORK( 1 ) ) ), RZERO )
END IF
*
* ==== End of ZHSEQR ====
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlabad.f 0000644 0000000 0000000 00000000132 13543334726 015140 x ustar 00 30 mtime=1569569238.429645905
30 atime=1569569238.428645906
30 ctime=1569569238.429645905
elk-6.3.2/src/LAPACK/dlabad.f 0000644 0025044 0025044 00000006015 13543334726 017211 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlange.f 0000644 0000000 0000000 00000000132 13543334726 015211 x ustar 00 30 mtime=1569569238.433645902
30 atime=1569569238.432645903
30 ctime=1569569238.433645902
elk-6.3.2/src/LAPACK/zlange.f 0000644 0025044 0025044 00000013417 13543334726 017266 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
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
TEMP = ABS( A( I, J ) )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
TEMP = WORK( I )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANGE = VALUE
RETURN
*
* End of ZLANGE
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zlascl.f 0000644 0000000 0000000 00000000130 13543334726 015217 x ustar 00 30 mtime=1569569238.438645899
28 atime=1569569238.4366459
30 ctime=1569569238.438645899
elk-6.3.2/src/LAPACK/zlascl.f 0000644 0025044 0025044 00000023435 13543334726 017277 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgebal.f 0000644 0000000 0000000 00000000132 13543334726 015175 x ustar 00 30 mtime=1569569238.442645897
30 atime=1569569238.441645897
30 ctime=1569569238.442645897
elk-6.3.2/src/LAPACK/zgebal.f 0000644 0025044 0025044 00000024716 13543334726 017256 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgehrd.f 0000644 0000000 0000000 00000000132 13543334726 015214 x ustar 00 30 mtime=1569569238.447645893
30 atime=1569569238.445645895
30 ctime=1569569238.447645893
elk-6.3.2/src/LAPACK/zgehrd.f 0000644 0025044 0025044 00000025255 13543334726 017274 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlacpy.f 0000644 0000000 0000000 00000000132 13543334726 015233 x ustar 00 30 mtime=1569569238.451645891
30 atime=1569569238.450645891
30 ctime=1569569238.451645891
elk-6.3.2/src/LAPACK/zlacpy.f 0000644 0025044 0025044 00000007754 13543334726 017317 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunghr.f 0000644 0000000 0000000 00000000132 13543334726 015246 x ustar 00 30 mtime=1569569238.456645888
30 atime=1569569238.454645889
30 ctime=1569569238.456645888
elk-6.3.2/src/LAPACK/zunghr.f 0000644 0025044 0025044 00000014707 13543334726 017326 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgebak.f 0000644 0000000 0000000 00000000132 13543334726 015174 x ustar 00 30 mtime=1569569238.460645885
30 atime=1569569238.459645886
30 ctime=1569569238.460645885
elk-6.3.2/src/LAPACK/zgebak.f 0000644 0025044 0025044 00000016157 13543334726 017255 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgetrs.f 0000644 0000000 0000000 00000000132 13543334726 015247 x ustar 00 30 mtime=1569569238.464645883
30 atime=1569569238.463645883
30 ctime=1569569238.464645883
elk-6.3.2/src/LAPACK/zgetrs.f 0000644 0025044 0025044 00000013643 13543334726 017325 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgetrf2.f 0000644 0000000 0000000 00000000130 13543334726 015312 x ustar 00 29 mtime=1569569238.46864588
30 atime=1569569238.467645881
29 ctime=1569569238.46864588
elk-6.3.2/src/LAPACK/zgetrf2.f 0000644 0025044 0025044 00000015711 13543334726 017370 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaswp.f 0000644 0000000 0000000 00000000132 13543334726 015251 x ustar 00 30 mtime=1569569238.472645877
30 atime=1569569238.471645878
30 ctime=1569569238.472645877
elk-6.3.2/src/LAPACK/zlaswp.f 0000644 0025044 0025044 00000012005 13543334726 017316 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-6.3.2/src/LAPACK/PaxHeaders.21352/ztrtri.f 0000644 0000000 0000000 00000000132 13543334726 015267 x ustar 00 30 mtime=1569569238.477645874
30 atime=1569569238.476645875
30 ctime=1569569238.477645874
elk-6.3.2/src/LAPACK/ztrtri.f 0000644 0025044 0025044 00000015450 13543334726 017343 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlanhe.f 0000644 0000000 0000000 00000000132 13543334726 015212 x ustar 00 30 mtime=1569569238.481645872
30 atime=1569569238.480645872
30 ctime=1569569238.481645872
elk-6.3.2/src/LAPACK/zlanhe.f 0000644 0025044 0025044 00000017672 13543334726 017276 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
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
SUM = ABS( DBLE( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
DO 40 J = 1, N
SUM = ABS( DBLE( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = J + 1, N
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
DO 130 I = 1, N
IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( A( I, I ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHE = VALUE
RETURN
*
* End of ZLANHE
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zhetrd.f 0000644 0000000 0000000 00000000131 13543334726 015230 x ustar 00 30 mtime=1569569238.486645868
29 atime=1569569238.48464587
30 ctime=1569569238.486645868
elk-6.3.2/src/LAPACK/zhetrd.f 0000644 0025044 0025044 00000026461 13543334726 017311 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-6.3.2/src/LAPACK/PaxHeaders.21352/zstedc.f 0000644 0000000 0000000 00000000132 13543334726 015225 x ustar 00 30 mtime=1569569238.491645865
30 atime=1569569238.489645867
30 ctime=1569569238.491645865
elk-6.3.2/src/LAPACK/zstedc.f 0000644 0025044 0025044 00000037324 13543334726 017305 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunmtr.f 0000644 0000000 0000000 00000000132 13543334726 015270 x ustar 00 30 mtime=1569569238.495645863
30 atime=1569569238.494645863
30 ctime=1569569238.495645863
elk-6.3.2/src/LAPACK/zunmtr.f 0000644 0025044 0025044 00000021123 13543334726 017336 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-6.3.2/src/LAPACK/PaxHeaders.21352/zungtr.f 0000644 0000000 0000000 00000000130 13543334726 015260 x ustar 00 29 mtime=1569569238.50064586
30 atime=1569569238.498645861
29 ctime=1569569238.50064586
elk-6.3.2/src/LAPACK/zungtr.f 0000644 0025044 0025044 00000015641 13543334726 017340 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-6.3.2/src/LAPACK/PaxHeaders.21352/zsteqr.f 0000644 0000000 0000000 00000000132 13543334726 015261 x ustar 00 30 mtime=1569569238.505645856
30 atime=1569569238.503645858
30 ctime=1569569238.505645856
elk-6.3.2/src/LAPACK/zsteqr.f 0000644 0025044 0025044 00000036610 13543334726 017336 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-6.3.2/src/LAPACK/PaxHeaders.21352/zpotrf.f 0000644 0000000 0000000 00000000132 13543334726 015255 x ustar 00 30 mtime=1569569238.509645854
30 atime=1569569238.508645854
30 ctime=1569569238.509645854
elk-6.3.2/src/LAPACK/zpotrf.f 0000644 0025044 0025044 00000016325 13543334726 017333 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhegst.f 0000644 0000000 0000000 00000000132 13543334726 015235 x ustar 00 30 mtime=1569569238.514645851
30 atime=1569569238.512645852
30 ctime=1569569238.514645851
elk-6.3.2/src/LAPACK/zhegst.f 0000644 0025044 0025044 00000026224 13543334726 017312 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.
*> \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-6.3.2/src/LAPACK/PaxHeaders.21352/zheevx.f 0000644 0000000 0000000 00000000132 13543334726 015242 x ustar 00 30 mtime=1569569238.519645847
30 atime=1569569238.517645849
30 ctime=1569569238.519645847
elk-6.3.2/src/LAPACK/zheevx.f 0000644 0025044 0025044 00000043344 13543334726 017321 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlanhp.f 0000644 0000000 0000000 00000000132 13543334726 015225 x ustar 00 30 mtime=1569569238.524645844
30 atime=1569569238.522645845
30 ctime=1569569238.524645844
elk-6.3.2/src/LAPACK/zlanhp.f 0000644 0025044 0025044 00000020170 13543334726 017274 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
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
K = 0
DO 20 J = 1, N
DO 10 I = K + 1, K + J - 1
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
K = K + J
SUM = ABS( DBLE( AP( K ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
SUM = ABS( DBLE( AP( K ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = K + 1, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( AP( K ) ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( AP( K ) ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( DBLE( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AP( K ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHP = VALUE
RETURN
*
* End of ZLANHP
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zhptrd.f 0000644 0000000 0000000 00000000132 13543334726 015244 x ustar 00 30 mtime=1569569238.528645842
30 atime=1569569238.527645842
30 ctime=1569569238.528645842
elk-6.3.2/src/LAPACK/zhptrd.f 0000644 0025044 0025044 00000021630 13543334726 017315 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-6.3.2/src/LAPACK/PaxHeaders.21352/zupgtr.f 0000644 0000000 0000000 00000000131 13543334726 015263 x ustar 00 30 mtime=1569569238.533645838
29 atime=1569569238.53164584
30 ctime=1569569238.533645838
elk-6.3.2/src/LAPACK/zupgtr.f 0000644 0025044 0025044 00000013732 13543334726 017341 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-6.3.2/src/LAPACK/PaxHeaders.21352/dstebz.f 0000644 0000000 0000000 00000000132 13543334726 015224 x ustar 00 30 mtime=1569569238.539645835
30 atime=1569569238.536645837
30 ctime=1569569238.539645835
elk-6.3.2/src/LAPACK/dstebz.f 0000644 0025044 0025044 00000057162 13543334726 017306 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-6.3.2/src/LAPACK/PaxHeaders.21352/zstein.f 0000644 0000000 0000000 00000000132 13543334726 015245 x ustar 00 30 mtime=1569569238.544645831
30 atime=1569569238.542645833
30 ctime=1569569238.544645831
elk-6.3.2/src/LAPACK/zstein.f 0000644 0025044 0025044 00000033420 13543334726 017316 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-6.3.2/src/LAPACK/PaxHeaders.21352/zupmtr.f 0000644 0000000 0000000 00000000132 13543334726 015272 x ustar 00 30 mtime=1569569238.548645829
30 atime=1569569238.547645829
30 ctime=1569569238.548645829
elk-6.3.2/src/LAPACK/zupmtr.f 0000644 0025044 0025044 00000021554 13543334726 017350 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlassq.f 0000644 0000000 0000000 00000000132 13543334726 015220 x ustar 00 30 mtime=1569569238.552645826
30 atime=1569569238.551645827
30 ctime=1569569238.552645826
elk-6.3.2/src/LAPACK/dlassq.f 0000644 0025044 0025044 00000010361 13543334726 017270 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 (N)
*> 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorgql.f 0000644 0000000 0000000 00000000132 13543334726 015221 x ustar 00 30 mtime=1569569238.557645823
30 atime=1569569238.555645824
30 ctime=1569569238.557645823
elk-6.3.2/src/LAPACK/dorgql.f 0000644 0025044 0025044 00000020006 13543334726 017266 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorgqr.f 0000644 0000000 0000000 00000000132 13543334726 015227 x ustar 00 30 mtime=1569569238.561645821
30 atime=1569569238.560645821
30 ctime=1569569238.561645821
elk-6.3.2/src/LAPACK/dorgqr.f 0000644 0025044 0025044 00000017610 13543334726 017303 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-6.3.2/src/LAPACK/PaxHeaders.21352/dpotrf2.f 0000644 0000000 0000000 00000000132 13543334726 015311 x ustar 00 30 mtime=1569569238.565645818
30 atime=1569569238.564645819
30 ctime=1569569238.565645818
elk-6.3.2/src/LAPACK/dpotrf2.f 0000644 0025044 0025044 00000014256 13543334726 017370 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaebz.f 0000644 0000000 0000000 00000000132 13543334726 015172 x ustar 00 30 mtime=1569569238.571645814
30 atime=1569569238.569645815
30 ctime=1569569238.571645814
elk-6.3.2/src/LAPACK/dlaebz.f 0000644 0025044 0025044 00000054020 13543334726 017242 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaset.f 0000644 0000000 0000000 00000000132 13543334726 015205 x ustar 00 30 mtime=1569569238.576645811
30 atime=1569569238.574645812
30 ctime=1569569238.576645811
elk-6.3.2/src/LAPACK/dlaset.f 0000644 0025044 0025044 00000011474 13543334726 017263 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlanst.f 0000644 0000000 0000000 00000000132 13543334726 015216 x ustar 00 30 mtime=1569569238.580645808
30 atime=1569569238.579645809
30 ctime=1569569238.580645808
elk-6.3.2/src/LAPACK/dlanst.f 0000644 0025044 0025044 00000012324 13543334726 017267 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaev2.f 0000644 0000000 0000000 00000000132 13543334726 015106 x ustar 00 30 mtime=1569569238.584645806
30 atime=1569569238.583645806
30 ctime=1569569238.584645806
elk-6.3.2/src/LAPACK/dlaev2.f 0000644 0025044 0025044 00000014072 13543334726 017161 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasr.f 0000644 0000000 0000000 00000000132 13543334726 015036 x ustar 00 30 mtime=1569569238.589645803
30 atime=1569569238.587645804
30 ctime=1569569238.589645803
elk-6.3.2/src/LAPACK/dlasr.f 0000644 0025044 0025044 00000035306 13543334726 017114 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 = 'R' or by A*P**T if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlae2.f 0000644 0000000 0000000 00000000132 13543334726 014720 x ustar 00 30 mtime=1569569238.594645799
30 atime=1569569238.592645801
30 ctime=1569569238.594645799
elk-6.3.2/src/LAPACK/dlae2.f 0000644 0025044 0025044 00000011311 13543334726 016764 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlapy2.f 0000644 0000000 0000000 00000000132 13543334726 015124 x ustar 00 30 mtime=1569569238.598645797
30 atime=1569569238.597645798
30 ctime=1569569238.598645797
elk-6.3.2/src/LAPACK/dlapy2.f 0000644 0025044 0025044 00000005466 13543334726 017206 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlartg.f 0000644 0000000 0000000 00000000132 13543334726 015206 x ustar 00 30 mtime=1569569238.602645794
30 atime=1569569238.601645795
30 ctime=1569569238.602645794
elk-6.3.2/src/LAPACK/dlartg.f 0000644 0025044 0025044 00000012613 13543334726 017260 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasrt.f 0000644 0000000 0000000 00000000132 13543334726 015222 x ustar 00 30 mtime=1569569238.607645791
30 atime=1569569238.605645792
30 ctime=1569569238.607645791
elk-6.3.2/src/LAPACK/dlasrt.f 0000644 0025044 0025044 00000017314 13543334726 017277 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlacpy.f 0000644 0000000 0000000 00000000132 13543334726 015205 x ustar 00 30 mtime=1569569238.611645789
30 atime=1569569238.610645789
30 ctime=1569569238.611645789
elk-6.3.2/src/LAPACK/dlacpy.f 0000644 0025044 0025044 00000010001 13543334726 017244 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-6.3.2/src/LAPACK/PaxHeaders.21352/dstein.f 0000644 0000000 0000000 00000000132 13543334726 015217 x ustar 00 30 mtime=1569569238.616645785
30 atime=1569569238.614645787
30 ctime=1569569238.616645785
elk-6.3.2/src/LAPACK/dstein.f 0000644 0025044 0025044 00000032141 13543334726 017267 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-6.3.2/src/LAPACK/PaxHeaders.21352/dormtr.f 0000644 0000000 0000000 00000000132 13543334726 015240 x ustar 00 30 mtime=1569569238.620645783
30 atime=1569569238.619645783
30 ctime=1569569238.620645783
elk-6.3.2/src/LAPACK/dormtr.f 0000644 0025044 0025044 00000021134 13543334726 017310 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsygs2.f 0000644 0000000 0000000 00000000130 13543334726 015142 x ustar 00 29 mtime=1569569238.62564578
30 atime=1569569238.623645781
29 ctime=1569569238.62564578
elk-6.3.2/src/LAPACK/dsygs2.f 0000644 0025044 0025044 00000021237 13543334726 017220 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlatrd.f 0000644 0000000 0000000 00000000132 13543334726 015203 x ustar 00 30 mtime=1569569238.630645776
30 atime=1569569238.628645778
30 ctime=1569569238.630645776
elk-6.3.2/src/LAPACK/dlatrd.f 0000644 0025044 0025044 00000026560 13543334726 017263 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-6.3.2/src/LAPACK/PaxHeaders.21352/dsytd2.f 0000644 0000000 0000000 00000000132 13543334726 015142 x ustar 00 30 mtime=1569569238.634645774
30 atime=1569569238.633645775
30 ctime=1569569238.634645774
elk-6.3.2/src/LAPACK/dsytd2.f 0000644 0025044 0025044 00000023172 13543334726 017216 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-6.3.2/src/LAPACK/PaxHeaders.21352/dtrti2.f 0000644 0000000 0000000 00000000132 13543334726 015141 x ustar 00 30 mtime=1569569238.638645771
30 atime=1569569238.637645772
30 ctime=1569569238.638645771
elk-6.3.2/src/LAPACK/dtrti2.f 0000644 0025044 0025044 00000013423 13543334726 017213 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlahr2.f 0000644 0000000 0000000 00000000132 13543334726 015133 x ustar 00 30 mtime=1569569238.643645768
30 atime=1569569238.642645769
30 ctime=1569569238.643645768
elk-6.3.2/src/LAPACK/zlahr2.f 0000644 0025044 0025044 00000024157 13543334726 017213 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlarfb.f 0000644 0000000 0000000 00000000132 13543334726 015211 x ustar 00 30 mtime=1569569238.649645764
30 atime=1569569238.646645766
30 ctime=1569569238.649645764
elk-6.3.2/src/LAPACK/zlarfb.f 0000644 0025044 0025044 00000053251 13543334726 017266 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).
*> \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-6.3.2/src/LAPACK/PaxHeaders.21352/zgehd2.f 0000644 0000000 0000000 00000000132 13543334726 015114 x ustar 00 30 mtime=1569569238.653645762
30 atime=1569569238.652645762
30 ctime=1569569238.653645762
elk-6.3.2/src/LAPACK/zgehd2.f 0000644 0025044 0025044 00000014673 13543334726 017176 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhegs2.f 0000644 0000000 0000000 00000000131 13543334726 015132 x ustar 00 30 mtime=1569569238.657645759
29 atime=1569569238.65664576
30 ctime=1569569238.657645759
elk-6.3.2/src/LAPACK/zhegs2.f 0000644 0025044 0025044 00000022414 13543334726 017205 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.
*> \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-6.3.2/src/LAPACK/PaxHeaders.21352/zlatrd.f 0000644 0000000 0000000 00000000132 13543334726 015231 x ustar 00 30 mtime=1569569238.662645756
30 atime=1569569238.661645757
30 ctime=1569569238.662645756
elk-6.3.2/src/LAPACK/zlatrd.f 0000644 0025044 0025044 00000030404 13543334726 017301 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-6.3.2/src/LAPACK/PaxHeaders.21352/zhetd2.f 0000644 0000000 0000000 00000000132 13543334726 015131 x ustar 00 30 mtime=1569569238.667645753
30 atime=1569569238.666645753
30 ctime=1569569238.667645753
elk-6.3.2/src/LAPACK/zhetd2.f 0000644 0025044 0025044 00000023711 13543334726 017204 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlarfg.f 0000644 0000000 0000000 00000000130 13543334726 015214 x ustar 00 29 mtime=1569569238.67164575
30 atime=1569569238.670645751
29 ctime=1569569238.67164575
elk-6.3.2/src/LAPACK/zlarfg.f 0000644 0025044 0025044 00000012455 13543334726 017274 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaqr0.f 0000644 0000000 0000000 00000000132 13543334726 015142 x ustar 00 30 mtime=1569569238.677645746
30 atime=1569569238.674645748
30 ctime=1569569238.677645746
elk-6.3.2/src/LAPACK/zlaqr0.f 0000644 0025044 0025044 00000060770 13543334726 017223 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 .GE. 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
*> previous call to ZGEBAL, and then passed to ZGEHRD when the
*> matrix output by ZGEBAL is reduced to Hessenberg form.
*> Otherwise, ILO and IHI should be set to 1 and N,
*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and WANTT is .TRUE., then H
*> contains the upper triangular matrix T from the Schur
*> decomposition (the Schur form). If INFO = 0 and WANT is
*> .FALSE., then the contents of H are unspecified on exit.
*> (The output value of H when INFO.GT.0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH .GE. max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
*> If WANTZ is .FALSE., then Z is not referenced.
*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
*> (The output value of Z when INFO.GT.0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if WANTZ is .TRUE.
*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK
*> On exit, if LWORK = -1, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK .GE. max(1,N)
*> is sufficient, but LWORK typically as large as 6*N may
*> be required for optimal performance. A workspace query
*> to determine the optimal workspace size is recommended.
*>
*> If LWORK = -1, then ZLAQR0 does a workspace query.
*> In this case, ZLAQR0 checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .GT. 0: if INFO = i, ZLAQR0 failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO .GT. 0 and WANT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*>
*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of WANTT.)
*>
*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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 magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
$ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
$ NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
70 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
80 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR0 ====
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zlaset.f 0000644 0000000 0000000 00000000132 13543334726 015233 x ustar 00 30 mtime=1569569238.682645743
30 atime=1569569238.680645745
30 ctime=1569569238.682645743
elk-6.3.2/src/LAPACK/zlaset.f 0000644 0025044 0025044 00000011360 13543334726 017303 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlahqr.f 0000644 0000000 0000000 00000000130 13543334726 015230 x ustar 00 29 mtime=1569569238.68764574
30 atime=1569569238.685645741
29 ctime=1569569238.68764574
elk-6.3.2/src/LAPACK/zlahqr.f 0000644 0025044 0025044 00000044064 13543334726 017311 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
*> .GT. 0: if INFO = i, ZLAHQR failed to compute all the
*> eigenvalues ILO to IHI in a total of 30 iterations
*> per eigenvalue; elements i+1:ihi of W contain
*> those eigenvalues which have been successfully
*> computed.
*>
*> If INFO .GT. 0 and WANTT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the
*> eigenvalues of the upper Hessenberg matrix
*> rows and columns ILO thorugh INFO of the final,
*> output value of H.
*>
*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
*> (*) (initial value of H)*U = U*(final value of H)
*> where U is an orthognal matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*> (final value of Z) = (initial value of Z)*U
*> where U is the orthogonal matrix in (*)
*> (regardless of the value of WANTT.)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlassq.f 0000644 0000000 0000000 00000000132 13543334726 015246 x ustar 00 30 mtime=1569569238.692645737
30 atime=1569569238.691645737
30 ctime=1569569238.692645737
elk-6.3.2/src/LAPACK/zlassq.f 0000644 0025044 0025044 00000011215 13543334726 017315 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 .le. ssq .le. ( sumsq + 2*n ).
*>
*> scale is assumed to be non-negative and scl returns the value
*>
*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
*> i
*>
*> scale and sumsq must be supplied in SCALE and SUMSQ respectively.
*> SCALE and SUMSQ are overwritten by scl and ssq respectively.
*>
*> The routine makes only one pass through the vector X.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements to be used from the vector X.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (N)
*> The vector x as described above.
*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of the vector X.
*> INCX > 0.
*> \endverbatim
*>
*> \param[in,out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On entry, the value scale in the equation above.
*> On exit, SCALE is overwritten with the value scl .
*> \endverbatim
*>
*> \param[in,out] SUMSQ
*> \verbatim
*> SUMSQ is DOUBLE PRECISION
*> On entry, the value sumsq in the equation above.
*> On exit, SUMSQ is overwritten with the value ssq .
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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-6.3.2/src/LAPACK/PaxHeaders.21352/zpotrf2.f 0000644 0000000 0000000 00000000132 13543334726 015337 x ustar 00 30 mtime=1569569238.696645734
30 atime=1569569238.695645735
30 ctime=1569569238.696645734
elk-6.3.2/src/LAPACK/zpotrf2.f 0000644 0025044 0025044 00000014461 13543334726 017414 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 real symmetric
*> 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 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**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-6.3.2/src/LAPACK/PaxHeaders.21352/dstedc.f 0000644 0000000 0000000 00000000132 13543334726 015177 x ustar 00 30 mtime=1569569238.701645731
30 atime=1569569238.699645732
30 ctime=1569569238.701645731
elk-6.3.2/src/LAPACK/dstedc.f 0000644 0025044 0025044 00000036326 13543334726 017260 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaed0.f 0000644 0000000 0000000 00000000132 13543334726 015110 x ustar 00 30 mtime=1569569238.706645728
30 atime=1569569238.704645729
30 ctime=1569569238.706645728
elk-6.3.2/src/LAPACK/zlaed0.f 0000644 0025044 0025044 00000026077 13543334726 017173 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlacrm.f 0000644 0000000 0000000 00000000132 13543334726 015221 x ustar 00 30 mtime=1569569238.710645725
30 atime=1569569238.709645726
30 ctime=1569569238.710645725
elk-6.3.2/src/LAPACK/zlacrm.f 0000644 0025044 0025044 00000011351 13543334726 017271 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlarnv.f 0000644 0000000 0000000 00000000132 13543334726 015217 x ustar 00 30 mtime=1569569238.714645723
30 atime=1569569238.713645723
30 ctime=1569569238.714645723
elk-6.3.2/src/LAPACK/dlarnv.f 0000644 0025044 0025044 00000011262 13543334726 017270 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlagtf.f 0000644 0000000 0000000 00000000127 13543334726 015176 x ustar 00 29 mtime=1569569238.71964572
29 atime=1569569238.71864572
29 ctime=1569569238.71964572
elk-6.3.2/src/LAPACK/dlagtf.f 0000644 0025044 0025044 00000020062 13543334726 017241 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) ).le. 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
*> .lt. 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlagts.f 0000644 0000000 0000000 00000000132 13543334726 015207 x ustar 00 30 mtime=1569569238.724645716
30 atime=1569569238.722645718
30 ctime=1569569238.724645716
elk-6.3.2/src/LAPACK/dlagts.f 0000644 0025044 0025044 00000030341 13543334726 017257 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 .lt. 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 .gt. 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
*> .lt. 0: if INFO = -i, the i-th argument had an illegal value
*> .gt. 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlasr.f 0000644 0000000 0000000 00000000132 13543334726 015064 x ustar 00 30 mtime=1569569238.729645713
30 atime=1569569238.727645714
30 ctime=1569569238.729645713
elk-6.3.2/src/LAPACK/zlasr.f 0000644 0025044 0025044 00000035433 13543334726 017143 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlatrs.f 0000644 0000000 0000000 00000000132 13543334726 015250 x ustar 00 30 mtime=1569569238.735645709
30 atime=1569569238.732645711
30 ctime=1569569238.735645709
elk-6.3.2/src/LAPACK/zlatrs.f 0000644 0025044 0025044 00000072535 13543334726 017333 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-6.3.2/src/LAPACK/PaxHeaders.21352/ztrti2.f 0000644 0000000 0000000 00000000132 13543334726 015167 x ustar 00 30 mtime=1569569238.740645706
30 atime=1569569238.738645707
30 ctime=1569569238.740645706
elk-6.3.2/src/LAPACK/ztrti2.f 0000644 0025044 0025044 00000013437 13543334726 017246 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-6.3.2/src/LAPACK/PaxHeaders.21352/zungqr.f 0000644 0000000 0000000 00000000132 13543334726 015257 x ustar 00 30 mtime=1569569238.744645704
30 atime=1569569238.743645704
30 ctime=1569569238.744645704
elk-6.3.2/src/LAPACK/zungqr.f 0000644 0025044 0025044 00000017610 13543334726 017333 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-6.3.2/src/LAPACK/PaxHeaders.21352/zungql.f 0000644 0000000 0000000 00000000126 13543334726 015254 x ustar 00 28 mtime=1569569238.7496457
30 atime=1569569238.747645702
28 ctime=1569569238.7496457
elk-6.3.2/src/LAPACK/zungql.f 0000644 0025044 0025044 00000020006 13543334726 017316 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunmql.f 0000644 0000000 0000000 00000000132 13543334726 015257 x ustar 00 30 mtime=1569569238.753645698
30 atime=1569569238.752645699
30 ctime=1569569238.753645698
elk-6.3.2/src/LAPACK/zunmql.f 0000644 0025044 0025044 00000022253 13543334726 017332 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunmqr.f 0000644 0000000 0000000 00000000132 13543334726 015265 x ustar 00 30 mtime=1569569238.758645695
30 atime=1569569238.756645696
30 ctime=1569569238.758645695
elk-6.3.2/src/LAPACK/zunmqr.f 0000644 0025044 0025044 00000022231 13543334726 017334 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-6.3.2/src/LAPACK/PaxHeaders.21352/zung2l.f 0000644 0000000 0000000 00000000132 13543334726 015152 x ustar 00 30 mtime=1569569238.762645692
30 atime=1569569238.761645693
30 ctime=1569569238.762645692
elk-6.3.2/src/LAPACK/zung2l.f 0000644 0025044 0025044 00000012250 13543334726 017221 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-6.3.2/src/LAPACK/PaxHeaders.21352/zung2r.f 0000644 0000000 0000000 00000000131 13543334726 015157 x ustar 00 30 mtime=1569569238.767645689
29 atime=1569569238.76564569
30 ctime=1569569238.767645689
elk-6.3.2/src/LAPACK/zung2r.f 0000644 0025044 0025044 00000012100 13543334726 017221 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlarf.f 0000644 0000000 0000000 00000000132 13543334726 015047 x ustar 00 30 mtime=1569569238.771645686
30 atime=1569569238.770645687
30 ctime=1569569238.771645686
elk-6.3.2/src/LAPACK/zlarf.f 0000644 0025044 0025044 00000014267 13543334726 017130 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaisnan.f 0000644 0000000 0000000 00000000132 13543334726 015522 x ustar 00 30 mtime=1569569238.775645684
30 atime=1569569238.774645684
30 ctime=1569569238.775645684
elk-6.3.2/src/LAPACK/dlaisnan.f 0000644 0025044 0025044 00000005060 13543334726 017572 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaruv.f 0000644 0000000 0000000 00000000130 13543334726 015224 x ustar 00 29 mtime=1569569238.78164568
30 atime=1569569238.779645681
29 ctime=1569569238.78164568
elk-6.3.2/src/LAPACK/dlaruv.f 0000644 0025044 0025044 00000044072 13543334726 017304 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlarfg.f 0000644 0000000 0000000 00000000132 13543334726 015170 x ustar 00 30 mtime=1569569238.785645677
30 atime=1569569238.784645678
30 ctime=1569569238.785645677
elk-6.3.2/src/LAPACK/dlarfg.f 0000644 0025044 0025044 00000011620 13543334726 017237 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorg2l.f 0000644 0000000 0000000 00000000132 13543334726 015122 x ustar 00 30 mtime=1569569238.790645674
30 atime=1569569238.789645675
30 ctime=1569569238.790645674
elk-6.3.2/src/LAPACK/dorg2l.f 0000644 0025044 0025044 00000012206 13543334726 017172 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlarft.f 0000644 0000000 0000000 00000000132 13543334726 015205 x ustar 00 30 mtime=1569569238.794645672
30 atime=1569569238.793645672
30 ctime=1569569238.794645672
elk-6.3.2/src/LAPACK/dlarft.f 0000644 0025044 0025044 00000024026 13543334726 017260 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlarfb.f 0000644 0000000 0000000 00000000132 13543334726 015163 x ustar 00 30 mtime=1569569238.800645668
30 atime=1569569238.798645669
30 ctime=1569569238.800645668
elk-6.3.2/src/LAPACK/dlarfb.f 0000644 0025044 0025044 00000051305 13543334726 017236 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).
*> \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-6.3.2/src/LAPACK/PaxHeaders.21352/dorg2r.f 0000644 0000000 0000000 00000000132 13543334726 015130 x ustar 00 30 mtime=1569569238.804645665
30 atime=1569569238.803645666
30 ctime=1569569238.804645665
elk-6.3.2/src/LAPACK/dorg2r.f 0000644 0025044 0025044 00000012220 13543334726 017174 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-6.3.2/src/LAPACK/PaxHeaders.21352/dormql.f 0000644 0000000 0000000 00000000132 13543334726 015227 x ustar 00 30 mtime=1569569238.809645662
30 atime=1569569238.807645663
30 ctime=1569569238.809645662
elk-6.3.2/src/LAPACK/dormql.f 0000644 0025044 0025044 00000022275 13543334726 017306 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-6.3.2/src/LAPACK/PaxHeaders.21352/dormqr.f 0000644 0000000 0000000 00000000131 13543334726 015234 x ustar 00 30 mtime=1569569238.814645659
29 atime=1569569238.81264566
30 ctime=1569569238.814645659
elk-6.3.2/src/LAPACK/dormqr.f 0000644 0025044 0025044 00000022241 13543334726 017305 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed0.f 0000644 0000000 0000000 00000000132 13543334726 015062 x ustar 00 30 mtime=1569569238.819645656
30 atime=1569569238.817645657
30 ctime=1569569238.819645656
elk-6.3.2/src/LAPACK/dlaed0.f 0000644 0025044 0025044 00000033106 13543334726 017134 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlacgv.f 0000644 0000000 0000000 00000000132 13543334726 015217 x ustar 00 30 mtime=1569569238.823645653
30 atime=1569569238.822645654
30 ctime=1569569238.823645653
elk-6.3.2/src/LAPACK/zlacgv.f 0000644 0025044 0025044 00000005444 13543334726 017275 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaed7.f 0000644 0000000 0000000 00000000130 13543334726 015115 x ustar 00 29 mtime=1569569238.82864565
30 atime=1569569238.826645651
29 ctime=1569569238.82864565
elk-6.3.2/src/LAPACK/zlaed7.f 0000644 0025044 0025044 00000030363 13543334726 017173 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-6.3.2/src/LAPACK/PaxHeaders.21352/zladiv.f 0000644 0000000 0000000 00000000132 13543334726 015222 x ustar 00 30 mtime=1569569238.832645647
30 atime=1569569238.831645648
30 ctime=1569569238.832645647
elk-6.3.2/src/LAPACK/zladiv.f 0000644 0025044 0025044 00000004571 13543334726 017300 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaqr3.f 0000644 0000000 0000000 00000000132 13543334726 015145 x ustar 00 30 mtime=1569569238.837645644
30 atime=1569569238.835645645
30 ctime=1569569238.837645644
elk-6.3.2/src/LAPACK/zlaqr3.f 0000644 0025044 0025044 00000043141 13543334726 017217 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 .LE. NW .LE. (KBOT-KTOP+1).
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input the initial N-by-N section of H stores the
*> Hessenberg matrix undergoing aggressive early deflation.
*> On output H has been transformed by a unitary
*> similarity transformation, perturbed, and the returned
*> to Hessenberg form that (it is to be hoped) has some
*> zero subdiagonal entries.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> Leading dimension of H just as declared in the calling
*> subroutine. N .LE. LDH
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> IF WANTZ is .TRUE., then on output, the unitary
*> similarity transformation mentioned above has been
*> accumulated into Z(ILOZ:IHIZ,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 .LE. LDZ.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*> NS is INTEGER
*> The number of unconverged (ie approximate) eigenvalues
*> returned in SR and SI that may be used as shifts by the
*> calling subroutine.
*> \endverbatim
*>
*> \param[out] ND
*> \verbatim
*> ND is INTEGER
*> The number of converged eigenvalues uncovered by this
*> subroutine.
*> \endverbatim
*>
*> \param[out] SH
*> \verbatim
*> SH is COMPLEX*16 array, dimension (KBOT)
*> On output, approximate eigenvalues that may
*> be used for shifts are stored in SH(KBOT-ND-NS+1)
*> through SR(KBOT-ND). Converged eigenvalues are
*> stored in SH(KBOT-ND+1) through SH(KBOT).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NW)
*> An NW-by-NW work array.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of V just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> The number of columns of T. NH.GE.NW.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NW)
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of T just as declared in the
*> calling subroutine. NW .LE. LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> The number of rows of work array WV available for
*> workspace. NV.GE.NW.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,NW)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is INTEGER
*> The leading dimension of W just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, WORK(1) is set to an estimate of the optimal value
*> of LWORK for the given values of N, NW, KTOP and KBOT.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the work array WORK. LWORK = 2*NW
*> suffices, but greater efficiency may result from larger
*> values of LWORK.
*>
*> If LWORK = -1, then a workspace query is assumed; ZLAQR3
*> only estimates the optimal workspace size for the given
*> values of N, NW, KTOP and KBOT. The estimate is returned
*> in WORK(1). No error message related to LWORK is issued
*> by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaqr4.f 0000644 0000000 0000000 00000000130 13543334726 015144 x ustar 00 29 mtime=1569569238.84364564
30 atime=1569569238.840645642
29 ctime=1569569238.84364564
elk-6.3.2/src/LAPACK/zlaqr4.f 0000644 0025044 0025044 00000061026 13543334726 017222 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 .GE. 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
*> previous call to ZGEBAL, and then passed to ZGEHRD when the
*> matrix output by ZGEBAL is reduced to Hessenberg form.
*> Otherwise, ILO and IHI should be set to 1 and N,
*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and WANTT is .TRUE., then H
*> contains the upper triangular matrix T from the Schur
*> decomposition (the Schur form). If INFO = 0 and WANT is
*> .FALSE., then the contents of H are unspecified on exit.
*> (The output value of H when INFO.GT.0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH .GE. max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
*> If WANTZ is .FALSE., then Z is not referenced.
*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
*> (The output value of Z when INFO.GT.0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if WANTZ is .TRUE.
*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK
*> On exit, if LWORK = -1, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK .GE. max(1,N)
*> is sufficient, but LWORK typically as large as 6*N may
*> be required for optimal performance. A workspace query
*> to determine the optimal workspace size is recommended.
*>
*> If LWORK = -1, then ZLAQR4 does a workspace query.
*> In this case, ZLAQR4 checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .GT. 0: if INFO = i, ZLAQR4 failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO .GT. 0 and WANT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*>
*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of WANTT.)
*>
*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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 magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
$ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
$ NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
70 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
80 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR4 ====
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zlaqr5.f 0000644 0000000 0000000 00000000132 13543334726 015147 x ustar 00 30 mtime=1569569238.850645636
30 atime=1569569238.846645638
30 ctime=1569569238.850645636
elk-6.3.2/src/LAPACK/zlaqr5.f 0000644 0025044 0025044 00000101457 13543334726 017226 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.GE.MAX(1,N).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, 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.GE.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.GE.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.GE.3*NSHFTS-3.
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> NH is the number of columns in array WH available for
*> workspace. NH.GE.1.
*> \endverbatim
*>
*> \param[out] WH
*> \verbatim
*> WH is COMPLEX*16 array, dimension (LDWH,NH)
*> \endverbatim
*>
*> \param[in] LDWH
*> \verbatim
*> LDWH is INTEGER
*> Leading dimension of WH just as declared in the
*> calling procedure. LDWH.GE.3*NSHFTS-3.
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> NV is the number of rows in WV agailable for workspace.
*> NV.GE.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.GE.NV.
*> \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-6.3.2/src/LAPACK/PaxHeaders.21352/ilazlc.f 0000644 0000000 0000000 00000000132 13543334726 015207 x ustar 00 30 mtime=1569569238.854645633
30 atime=1569569238.853645634
30 ctime=1569569238.854645633
elk-6.3.2/src/LAPACK/ilazlc.f 0000644 0025044 0025044 00000005657 13543334726 017273 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-6.3.2/src/LAPACK/PaxHeaders.21352/ilazlr.f 0000644 0000000 0000000 00000000132 13543334726 015226 x ustar 00 30 mtime=1569569238.858645631
30 atime=1569569238.857645631
30 ctime=1569569238.858645631
elk-6.3.2/src/LAPACK/ilazlr.f 0000644 0025044 0025044 00000005742 13543334726 017305 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlapy3.f 0000644 0000000 0000000 00000000132 13543334726 015125 x ustar 00 30 mtime=1569569238.862645628
30 atime=1569569238.861645629
30 ctime=1569569238.862645628
elk-6.3.2/src/LAPACK/dlapy3.f 0000644 0025044 0025044 00000005266 13543334726 017205 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlarft.f 0000644 0000000 0000000 00000000132 13543334726 015233 x ustar 00 30 mtime=1569569238.867645625
30 atime=1569569238.865645626
30 ctime=1569569238.867645625
elk-6.3.2/src/LAPACK/zlarft.f 0000644 0025044 0025044 00000024155 13543334726 017311 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunm2l.f 0000644 0000000 0000000 00000000132 13543334726 015160 x ustar 00 30 mtime=1569569238.872645622
30 atime=1569569238.870645623
30 ctime=1569569238.872645622
elk-6.3.2/src/LAPACK/zunm2l.f 0000644 0025044 0025044 00000016423 13543334726 017235 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunm2r.f 0000644 0000000 0000000 00000000131 13543334726 015165 x ustar 00 30 mtime=1569569238.876645619
29 atime=1569569238.87564562
30 ctime=1569569238.876645619
elk-6.3.2/src/LAPACK/zunm2r.f 0000644 0025044 0025044 00000016552 13543334726 017246 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed7.f 0000644 0000000 0000000 00000000132 13543334726 015071 x ustar 00 30 mtime=1569569238.881645616
30 atime=1569569238.879645617
30 ctime=1569569238.881645616
elk-6.3.2/src/LAPACK/dlaed7.f 0000644 0025044 0025044 00000031723 13543334726 017146 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlarf.f 0000644 0000000 0000000 00000000132 13543334726 015021 x ustar 00 30 mtime=1569569238.885645614
30 atime=1569569238.884645614
30 ctime=1569569238.885645614
elk-6.3.2/src/LAPACK/dlarf.f 0000644 0025044 0025044 00000014110 13543334726 017065 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorm2l.f 0000644 0000000 0000000 00000000130 13543334726 015126 x ustar 00 29 mtime=1569569238.89064561
30 atime=1569569238.888645612
29 ctime=1569569238.89064561
elk-6.3.2/src/LAPACK/dorm2l.f 0000644 0025044 0025044 00000016221 13543334726 017201 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorm2r.f 0000644 0000000 0000000 00000000132 13543334726 015136 x ustar 00 30 mtime=1569569238.894645608
30 atime=1569569238.893645608
30 ctime=1569569238.894645608
elk-6.3.2/src/LAPACK/dorm2r.f 0000644 0025044 0025044 00000016322 13543334726 017211 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-6.3.2/src/LAPACK/PaxHeaders.21352/dladiv.f 0000644 0000000 0000000 00000000132 13543334726 015174 x ustar 00 30 mtime=1569569238.898645605
30 atime=1569569238.897645606
30 ctime=1569569238.898645605
elk-6.3.2/src/LAPACK/dladiv.f 0000644 0025044 0025044 00000013706 13543334726 017252 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaeda.f 0000644 0000000 0000000 00000000132 13543334726 015143 x ustar 00 30 mtime=1569569238.903645602
30 atime=1569569238.901645603
30 ctime=1569569238.903645602
elk-6.3.2/src/LAPACK/dlaeda.f 0000644 0025044 0025044 00000023240 13543334726 017213 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaed8.f 0000644 0000000 0000000 00000000130 13543334726 015116 x ustar 00 30 mtime=1569569238.908645599
28 atime=1569569238.9066456
30 ctime=1569569238.908645599
elk-6.3.2/src/LAPACK/zlaed8.f 0000644 0025044 0025044 00000035225 13543334726 017176 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed9.f 0000644 0000000 0000000 00000000132 13543334726 015073 x ustar 00 30 mtime=1569569238.912645596
30 atime=1569569238.911645597
30 ctime=1569569238.912645596
elk-6.3.2/src/LAPACK/dlaed9.f 0000644 0025044 0025044 00000020722 13543334726 017145 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlamrg.f 0000644 0000000 0000000 00000000132 13543334726 015177 x ustar 00 30 mtime=1569569238.917645593
30 atime=1569569238.916645594
30 ctime=1569569238.917645593
elk-6.3.2/src/LAPACK/dlamrg.f 0000644 0025044 0025044 00000010713 13543334726 017250 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunmhr.f 0000644 0000000 0000000 00000000132 13543334726 015254 x ustar 00 30 mtime=1569569238.921645591
30 atime=1569569238.920645591
30 ctime=1569569238.921645591
elk-6.3.2/src/LAPACK/zunmhr.f 0000644 0025044 0025044 00000020247 13543334726 017330 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-6.3.2/src/LAPACK/PaxHeaders.21352/ztrexc.f 0000644 0000000 0000000 00000000132 13543334726 015250 x ustar 00 30 mtime=1569569238.926645587
30 atime=1569569238.924645589
30 ctime=1569569238.926645587
elk-6.3.2/src/LAPACK/ztrexc.f 0000644 0025044 0025044 00000014563 13543334726 017330 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaqr2.f 0000644 0000000 0000000 00000000132 13543334726 015144 x ustar 00 30 mtime=1569569238.931645584
30 atime=1569569238.929645585
30 ctime=1569569238.931645584
elk-6.3.2/src/LAPACK/zlaqr2.f 0000644 0025044 0025044 00000042262 13543334726 017221 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 .LE. NW .LE. (KBOT-KTOP+1).
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input the initial N-by-N section of H stores the
*> Hessenberg matrix undergoing aggressive early deflation.
*> On output H has been transformed by a unitary
*> similarity transformation, perturbed, and the returned
*> to Hessenberg form that (it is to be hoped) has some
*> zero subdiagonal entries.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> Leading dimension of H just as declared in the calling
*> subroutine. N .LE. LDH
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> IF WANTZ is .TRUE., then on output, the unitary
*> similarity transformation mentioned above has been
*> accumulated into Z(ILOZ:IHIZ,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 .LE. LDZ.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*> NS is INTEGER
*> The number of unconverged (ie approximate) eigenvalues
*> returned in SR and SI that may be used as shifts by the
*> calling subroutine.
*> \endverbatim
*>
*> \param[out] ND
*> \verbatim
*> ND is INTEGER
*> The number of converged eigenvalues uncovered by this
*> subroutine.
*> \endverbatim
*>
*> \param[out] SH
*> \verbatim
*> SH is COMPLEX*16 array, dimension (KBOT)
*> On output, approximate eigenvalues that may
*> be used for shifts are stored in SH(KBOT-ND-NS+1)
*> through SR(KBOT-ND). Converged eigenvalues are
*> stored in SH(KBOT-ND+1) through SH(KBOT).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NW)
*> An NW-by-NW work array.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of V just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> The number of columns of T. NH.GE.NW.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NW)
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of T just as declared in the
*> calling subroutine. NW .LE. LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> The number of rows of work array WV available for
*> workspace. NV.GE.NW.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,NW)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is INTEGER
*> The leading dimension of W just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, WORK(1) is set to an estimate of the optimal value
*> of LWORK for the given values of N, NW, KTOP and KBOT.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the work array WORK. LWORK = 2*NW
*> suffices, but greater efficiency may result from larger
*> values of LWORK.
*>
*> If LWORK = -1, then a workspace query is assumed; ZLAQR2
*> only estimates the optimal workspace size for the given
*> values of N, NW, KTOP and KBOT. The estimate is returned
*> in WORK(1). No error message related to LWORK is issued
*> by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlaqr1.f 0000644 0000000 0000000 00000000132 13543334726 015143 x ustar 00 30 mtime=1569569238.935645582
30 atime=1569569238.934645582
30 ctime=1569569238.935645582
elk-6.3.2/src/LAPACK/zlaqr1.f 0000644 0025044 0025044 00000011353 13543334726 017215 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.GE.N
*> \endverbatim
*>
*> \param[in] S1
*> \verbatim
*> S1 is COMPLEX*16
*> \endverbatim
*>
*> \param[in] S2
*> \verbatim
*> S2 is COMPLEX*16
*>
*> S1 and S2 are the shifts defining K in (*) above.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, 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 ..
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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed3.f 0000644 0000000 0000000 00000000131 13543334726 015064 x ustar 00 30 mtime=1569569238.940645578
29 atime=1569569238.93864558
30 ctime=1569569238.940645578
elk-6.3.2/src/LAPACK/dlaed3.f 0000644 0025044 0025044 00000025300 13543334726 017134 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed8.f 0000644 0000000 0000000 00000000132 13543334726 015072 x ustar 00 30 mtime=1569569238.945645575
30 atime=1569569238.943645576
30 ctime=1569569238.945645575
elk-6.3.2/src/LAPACK/dlaed8.f 0000644 0025044 0025044 00000037262 13543334726 017153 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 tolerence
*
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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed4.f 0000644 0000000 0000000 00000000132 13543334726 015066 x ustar 00 30 mtime=1569569238.951645571
30 atime=1569569238.948645573
30 ctime=1569569238.951645571
elk-6.3.2/src/LAPACK/dlaed4.f 0000644 0025044 0025044 00000064634 13543334726 017152 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 .GT. 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-6.3.2/src/LAPACK/PaxHeaders.21352/iladlc.f 0000644 0000000 0000000 00000000132 13543334726 015161 x ustar 00 30 mtime=1569569238.955645569
30 atime=1569569238.954645569
30 ctime=1569569238.955645569
elk-6.3.2/src/LAPACK/iladlc.f 0000644 0025044 0025044 00000005642 13543334726 017237 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-6.3.2/src/LAPACK/PaxHeaders.21352/iladlr.f 0000644 0000000 0000000 00000000132 13543334726 015200 x ustar 00 30 mtime=1569569238.959645566
30 atime=1569569238.958645567
30 ctime=1569569238.959645566
elk-6.3.2/src/LAPACK/iladlr.f 0000644 0025044 0025044 00000005725 13543334726 017260 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-6.3.2/src/LAPACK/PaxHeaders.21352/zlartg.f 0000644 0000000 0000000 00000000132 13543334726 015234 x ustar 00 30 mtime=1569569238.964645563
30 atime=1569569238.962645564
30 ctime=1569569238.964645563
elk-6.3.2/src/LAPACK/zlartg.f 0000644 0025044 0025044 00000016322 13543334726 017307 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-6.3.2/src/LAPACK/PaxHeaders.21352/zrot.f 0000644 0000000 0000000 00000000132 13543334726 014727 x ustar 00 30 mtime=1569569238.968645561
30 atime=1569569238.967645561
30 ctime=1569569238.968645561
elk-6.3.2/src/LAPACK/zrot.f 0000644 0025044 0025044 00000010134 13543334726 016775 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlaed6.f 0000644 0000000 0000000 00000000132 13543334726 015070 x ustar 00 30 mtime=1569569238.972645558
30 atime=1569569238.971645559
30 ctime=1569569238.972645558
elk-6.3.2/src/LAPACK/dlaed6.f 0000644 0025044 0025044 00000026553 13543334726 017152 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgeqrf.f 0000644 0000000 0000000 00000000132 13543334726 015201 x ustar 00 30 mtime=1569569238.977645555
30 atime=1569569238.975645556
30 ctime=1569569238.977645555
elk-6.3.2/src/LAPACK/dgeqrf.f 0000644 0025044 0025044 00000016634 13543334726 017262 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGEQRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGEQRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEQRF computes a QR factorization of a real M-by-N matrix A:
*> A = Q * R.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 orthogonal 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 DOUBLE PRECISION array, dimension (min(M,N))
*> 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 >= 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 December 2016
*
*> \ingroup doubleGEcomputational
*
*> \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**T
*>
*> where tau is a real scalar, and v is a real 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 DGEQRF( M, 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 ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'DGEQRF', ' ', 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( 'DGEQRF', -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, 'DGEQRF', ' ', 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, 'DGEQRF', ' ', 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 DGEQR2( 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 DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**T to A(i:m,i+ib:n) from the left
*
CALL DLARFB( 'Left', '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 DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of DGEQRF
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/Makefile 0000644 0000000 0000000 00000000132 13543334726 015222 x ustar 00 30 mtime=1569569238.981645552
30 atime=1569569238.980645553
30 ctime=1569569238.981645552
elk-6.3.2/src/LAPACK/Makefile 0000644 0025044 0025044 00000005413 13543334726 017274 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 = \
dbdsqr.f dgebd2.f dgebrd.f dgelq2.f dgelqf.f dgeqr2.f dgeqrf.f \
dgesvd.f dgesv.f dgetrf2.f dgetrf.f dgetri.f dgetrs.f disnan.f \
dlabad.f dlabrd.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 dlange.f dlansp.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 dopgtr.f dopmtr.f dorg2l.f dorg2r.f dorgbr.f \
dorgl2.f dorglq.f dorgql.f dorgqr.f dorgtr.f dorm2l.f dorm2r.f \
dormbr.f dorml2.f dormlq.f dormql.f dormqr.f dormtr.f dpotrf2.f \
dpotrf.f dspev.f dspevx.f dsptrd.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 dzsum1.f ieeeck.f iladlc.f \
iladlr.f ilaenv.f ilazlc.f ilazlr.f iparmq.f izmax1.f xerbla.f \
zbdsqr.f zgbsv.f zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f \
zgebd2.f zgebrd.f zgees.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 zlacn2.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 ztrsen.f ztrsyl.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 iparam2stage.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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasq4.f 0000644 0000000 0000000 00000000131 13543334726 015120 x ustar 00 30 mtime=1569569238.986645549
29 atime=1569569238.98464555
30 ctime=1569569238.986645549
elk-6.3.2/src/LAPACK/dlasq4.f 0000644 0025044 0025044 00000026634 13543334726 017203 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-6.3.2/src/LAPACK/PaxHeaders.21352/dgesvd.f 0000644 0000000 0000000 00000000132 13543334727 015206 x ustar 00 30 mtime=1569569239.001645539
30 atime=1569569238.989645547
30 ctime=1569569239.001645539
elk-6.3.2/src/LAPACK/dgesvd.f 0000644 0025044 0025044 00000412315 13543334727 017263 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief DGESVD computes the singular value decomposition (SVD) for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGESVD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBU, JOBVT
* INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
* $ VT( LDVT, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGESVD computes the singular value decomposition (SVD) of a real
*> M-by-N matrix A, optionally computing the left and/or right singular
*> vectors. The SVD is written
*>
*> A = U * SIGMA * 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 orthogonal matrix, and
*> V is an N-by-N orthogonal 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**T, 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**T:
*> = 'A': all N rows of V**T are returned in the array VT;
*> = 'S': the first min(m,n) rows of V**T (the right singular
*> vectors) are returned in the array VT;
*> = 'O': the first min(m,n) rows of V**T (the right singular
*> vectors) are overwritten on the array A;
*> = 'N': no rows of V**T (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 DOUBLE PRECISION 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**T (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 DOUBLE PRECISION 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 orthogonal 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 DOUBLE PRECISION array, dimension (LDVT,N)
*> If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
*> V**T;
*> if JOBVT = 'S', VT contains the first min(m,n) rows of
*> V**T (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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
*> if INFO > 0, WORK(2:MIN(M,N)) 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[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> LWORK >= MAX(1,5*MIN(M,N)) for the paths (see comments inside code):
*> - PATH 1 (M much larger than N, JOBU='N')
*> - PATH 1t (N much larger than M, JOBVT='N')
*> LWORK >= MAX(1,3*MIN(M,N) + MAX(M,N),5*MIN(M,N)) for the other paths
*> 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.
*> > 0: if DBDSQR did not converge, INFO specifies how many
*> superdiagonals of an intermediate bidiagonal form B
*> did not converge to zero. See the description of WORK
*> 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 doubleGEsing
*
* =====================================================================
SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
$ VT, LDVT, 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..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER JOBU, JOBVT
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
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 BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
$ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
$ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
$ NRVT, WRKBL
INTEGER LWORK_DGEQRF, LWORK_DORGQR_N, LWORK_DORGQR_M,
$ LWORK_DGEBRD, LWORK_DORGBR_P, LWORK_DORGBR_Q,
$ LWORK_DGELQF, LWORK_DORGLQ_N, LWORK_DORGLQ_M
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
$ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. 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.
* 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
*
* Compute space needed for DBDSQR
*
MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
BDSPAC = 5*N
* Compute space needed for DGEQRF
CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR )
LWORK_DGEQRF = INT( DUM(1) )
* Compute space needed for DORGQR
CALL DORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR )
LWORK_DORGQR_N = INT( DUM(1) )
CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR )
LWORK_DORGQR_M = INT( DUM(1) )
* Compute space needed for DGEBRD
CALL DGEBRD( N, N, A, LDA, S, DUM(1), DUM(1),
$ DUM(1), DUM(1), -1, IERR )
LWORK_DGEBRD = INT( DUM(1) )
* Compute space needed for DORGBR P
CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_P = INT( DUM(1) )
* Compute space needed for DORGBR Q
CALL DORGBR( 'Q', N, N, N, A, LDA, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_Q = INT( DUM(1) )
*
IF( M.GE.MNTHR ) THEN
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
*
MAXWRK = N + LWORK_DGEQRF
MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD )
IF( WNTVO .OR. WNTVAS )
$ MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 4*N, BDSPAC )
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N )
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N )
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*N*N + WRKBL
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*N*N + WRKBL
MINWRK = MAX( 3*N + M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_DGEQRF
WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M )
WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N + M, BDSPAC )
END IF
ELSE
*
* Path 10 (M at least N, but not much larger)
*
CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1),
$ DUM(1), DUM(1), -1, IERR )
LWORK_DGEBRD = INT( DUM(1) )
MAXWRK = 3*N + LWORK_DGEBRD
IF( WNTUS .OR. WNTUO ) THEN
CALL DORGBR( 'Q', M, N, N, A, LDA, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_Q = INT( DUM(1) )
MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q )
END IF
IF( WNTUA ) THEN
CALL DORGBR( 'Q', M, M, N, A, LDA, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_Q = INT( DUM(1) )
MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q )
END IF
IF( .NOT.WNTVN ) THEN
MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P )
END IF
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 3*N + M, BDSPAC )
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* Compute space needed for DBDSQR
*
MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
BDSPAC = 5*M
* Compute space needed for DGELQF
CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR )
LWORK_DGELQF = INT( DUM(1) )
* Compute space needed for DORGLQ
CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR )
LWORK_DORGLQ_N = INT( DUM(1) )
CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR )
LWORK_DORGLQ_M = INT( DUM(1) )
* Compute space needed for DGEBRD
CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1),
$ DUM(1), DUM(1), -1, IERR )
LWORK_DGEBRD = INT( DUM(1) )
* Compute space needed for DORGBR P
CALL DORGBR( 'P', M, M, M, A, N, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_P = INT( DUM(1) )
* Compute space needed for DORGBR Q
CALL DORGBR( 'Q', M, M, M, A, N, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_Q = INT( DUM(1) )
IF( N.GE.MNTHR ) THEN
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
*
MAXWRK = M + LWORK_DGELQF
MAXWRK = MAX( MAXWRK, 3*M + LWORK_DGEBRD )
IF( WNTUO .OR. WNTUAS )
$ MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 4*M, BDSPAC )
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M )
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A',
* JOBVT='O')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M )
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*M*M + WRKBL
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*M*M + WRKBL
MINWRK = MAX( 3*M + N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
*
WRKBL = M + LWORK_DGELQF
WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N )
WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P )
WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M + N, BDSPAC )
END IF
ELSE
*
* Path 10t(N greater than M, but not much larger)
*
CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1),
$ DUM(1), DUM(1), -1, IERR )
LWORK_DGEBRD = INT( DUM(1) )
MAXWRK = 3*M + LWORK_DGEBRD
IF( WNTVS .OR. WNTVO ) THEN
* Compute space needed for DORGBR P
CALL DORGBR( 'P', M, N, M, A, N, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_P = INT( DUM(1) )
MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P )
END IF
IF( WNTVA ) THEN
CALL DORGBR( 'P', N, N, M, A, N, DUM(1),
$ DUM(1), -1, IERR )
LWORK_DORGBR_P = INT( DUM(1) )
MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P )
END IF
IF( .NOT.WNTUN ) THEN
MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q )
END IF
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 3*M + N, BDSPAC )
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( 'DGESVD', -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 = DLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
CALL DLASCL( '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
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out below R
*
IF( N .GT. 1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
END IF
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( 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'.
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
NCVT = N
END IF
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A if desired
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
$ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
*
* If right singular vectors desired in VT, copy them there
*
IF( WNTVAS )
$ CALL DLACPY( '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+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N + 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*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 ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR) and zero out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
$ WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + N
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (Workspace: need N*N + 2*N, prefer N*N + M*N + N)
*
DO 10 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing A
* (Workspace: need 4*N, prefer 3*N + N*NB)
*
CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
$ A, LDA, DUM, 1, WORK( IWORK ), 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+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N + 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*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 ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (Workspace: need N*N + 4*N-1, prefer N*N + 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR) and computing right
* singular vectors of R in VT
* (Workspace: need N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
$ WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + N
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (Workspace: need N*N + 2*N, prefer N*N + M*N + N)
*
DO 20 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( '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
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in A by left vectors bidiagonalizing R
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( '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
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
$ A, LDA, DUM, 1, WORK( IWORK ), 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+MAX( 4*N, BDSPAC ) ) 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
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
$ 1, WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IR ), LDWRKR, ZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
$ 1, U, LDU, DUM, 1, WORK( IWORK ),
$ 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+MAX( 4*N, BDSPAC ) ) 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
* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*N*N + 4*N,
* prefer 2*N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*N*N + 4*N-1,
* prefer 2*N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = 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)
* (Workspace: need 2*N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IU ), LDWRKU, ZERO, U, LDU )
*
* Copy right singular vectors of R to A
* (Workspace: need N*N)
*
CALL DLACPY( '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
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( '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
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
$ LDA, U, LDU, DUM, 1, WORK( IWORK ),
$ 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+MAX( 4*N, BDSPAC ) ) 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
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need N*N + 4*N-1,
* prefer N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (Workspace: need N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IU ), LDWRKU, ZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ 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, 4*N, BDSPAC ) ) 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
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in U
* (Workspace: need N*N + N + M, prefer N*N + N + M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
$ 1, WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IR), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IR ), LDWRKR, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( '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
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N + M, prefer N + M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
$ 1, U, LDU, DUM, 1, WORK( IWORK ),
$ 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, 4*N, BDSPAC ) ) 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
* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N*N + N + M, prefer 2*N*N + N + M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*N*N + 4*N,
* prefer 2*N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*N*N + 4*N-1,
* prefer 2*N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = 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)
* (Workspace: need 2*N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IU ), LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
*
* Copy right singular vectors of R from WORK(IR) to A
*
CALL DLACPY( '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
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N + M, prefer N + M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
$ LDA, U, LDU, DUM, 1, WORK( IWORK ),
$ 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, 4*N, BDSPAC ) ) 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
* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N + N + M, prefer N*N + N + M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need N*N + 4*N-1,
* prefer N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (Workspace: need N*N + BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IU ), LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( '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
* (Workspace: need 2*N, prefer N + N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N + M, prefer N + M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R from A to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N + 2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (Workspace: need 3*N + M, prefer 3*N + M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ 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 = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( 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
* (Workspace: need 3*N + NCU, prefer 3*N + NCU*NB)
*
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
IF( WNTUS )
$ NCU = N
IF( WNTUA )
$ NCU = M
CALL DORGBR( '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
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL DORGBR( '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
* (Workspace: need 4*N, prefer 3*N + N*NB)
*
CALL DORGBR( '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
* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = 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
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ), 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
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ), 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
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out above L
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUO .OR. WNTUAS ) THEN
*
* If left singular vectors desired, generate Q
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + M
NRU = 0
IF( WNTUO .OR. WNTUAS )
$ NRU = M
*
* Perform bidiagonal QR iteration, computing left singular
* vectors of A in A if desired
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
$ LDA, DUM, 1, WORK( IWORK ), INFO )
*
* If left singular vectors desired in U, copy them there
*
IF( WNTUAS )
$ CALL DLACPY( '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+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + 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*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 ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR) and zero out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L
* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + M
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (Workspace: need M*M + 2*M, prefer M*M + M*N + M)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing A
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
$ DUM, 1, DUM, 1, WORK( IWORK ), 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+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + 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*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 ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing about above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U, copying result to WORK(IR)
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
*
* Generate right vectors bidiagonalizing L in WORK(IR)
* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U, and computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + M
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (Workspace: need M*M + 2*M, prefer M*M + M*N + M))
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( '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
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in A
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), 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+MAX( 4*M, BDSPAC ) ) 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
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L in
* WORK(IR)
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
$ LDWRKR, A, LDA, ZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy result to VT
*
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
$ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
$ 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+MAX( 4*M, BDSPAC ) ) 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
* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out below it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*M*M + 4*M,
* prefer 2*M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*M*M + 4*M-1,
* prefer 2*M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = 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)
* (Workspace: need 2*M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, A, LDA, ZERO, VT, LDVT )
*
* Copy left singular vectors of L to A
* (Workspace: need M*M)
*
CALL DLACPY( '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
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors of L in A
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, compute left
* singular vectors of A in A and compute right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
$ 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+MAX( 4*M, BDSPAC ) ) 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
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need M*M + 4*M-1,
* prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (Workspace: need M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, A, LDA, ZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ 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, 4*M, BDSPAC ) ) 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
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in VT
* (Workspace: need M*M + M + N, prefer M*M + M + N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need M*M + 4*M-1,
* prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
$ LDWRKR, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( '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
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M + N, prefer M + N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
$ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
$ 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, 4*M, BDSPAC ) ) 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
* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M*M + M + N, prefer 2*M*M + M + N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*M*M + 4*M,
* prefer 2*M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*M*M + 4*M-1,
* prefer 2*M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = 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)
* (Workspace: need 2*M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
* Copy left singular vectors of A from WORK(IR) to A
*
CALL DLACPY( '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
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M + N, prefer M + N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
$ 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, 4*M, BDSPAC ) ) 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
* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M + M + N, prefer M*M + M + N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (Workspace: need M*M + BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( '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
* (Workspace: need 2*M, prefer M + M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M + N, prefer M + N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M + 2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (Workspace: need 3*M + N, prefer 3*M + N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ 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 = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( 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
* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB)
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DORGBR( '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
* (Workspace: need 3*M + NRVT, prefer 3*M + NRVT*NB)
*
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
IF( WNTVA )
$ NRVT = N
IF( WNTVS )
$ NRVT = M
CALL DORGBR( '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
* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB)
*
CALL DORGBR( '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
* (Workspace: need 4*M, prefer 3*M + M*NB)
*
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = 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
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ), 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
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
END IF
*
END IF
*
END IF
*
* If DBDSQR failed to converge, copy unconverged superdiagonals
* to WORK( 2:MINMN )
*
IF( INFO.NE.0 ) THEN
IF( IE.GT.2 ) THEN
DO 50 I = 1, MINMN - 1
WORK( I+1 ) = WORK( I+IE-1 )
50 CONTINUE
END IF
IF( IE.LT.2 ) THEN
DO 60 I = MINMN - 1, 1, -1
WORK( I+1 ) = WORK( I+IE-1 )
60 CONTINUE
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, WORK( 2 ),
$ 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, WORK( 2 ),
$ MINMN, IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of DGESVD
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dgebrd.f 0000644 0000000 0000000 00000000132 13543334727 015161 x ustar 00 30 mtime=1569569239.006645536
30 atime=1569569239.004645538
30 ctime=1569569239.006645536
elk-6.3.2/src/LAPACK/dgebrd.f 0000644 0025044 0025044 00000025747 13543334727 017247 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGEBRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGEBRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
* $ TAUQ( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEBRD reduces a general real M-by-N matrix A to upper or lower
*> bidiagonal form B by an orthogonal transformation: Q**T * 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 DOUBLE PRECISION 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 orthogonal matrix Q as a product of elementary
*> reflectors, and the elements above the first superdiagonal,
*> with the array TAUP, represent the orthogonal 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 orthogonal matrix Q as a product of
*> elementary reflectors, and the elements above the diagonal,
*> with the array TAUP, represent the orthogonal 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 DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the orthogonal matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the orthogonal matrix P. 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 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 doubleGEcomputational
*
*> \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**T and G(i) = I - taup * u * u**T
*>
*> where tauq and taup are real scalars, and v and u are real 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**T and G(i) = I - taup * u * u**T
*>
*> where tauq and taup are real scalars, and v and u are real 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 DGEBRD( 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 A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
$ NBMIN, NX, WS
* ..
* .. External Subroutines ..
EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA
* ..
* .. 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, 'DGEBRD', ' ', 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( 'DGEBRD', -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, 'DGEBRD', ' ', 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, 'DGEBRD', ' ', 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+nb-1 to bidiagonal form and return
* the matrices X and Y which are needed to update the unreduced
* part of the matrix
*
CALL DLABRD( 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+nb:m,i+nb:n), using an update
* of the form A := A - V*Y**T - X*U**T
*
CALL DGEMM( 'No transpose', '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 DGEMM( '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 DGEBD2( 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 DGEBRD
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlasq3.f 0000644 0000000 0000000 00000000132 13543334727 015121 x ustar 00 30 mtime=1569569239.011645533
30 atime=1569569239.009645534
30 ctime=1569569239.011645533
elk-6.3.2/src/LAPACK/dlasq3.f 0000644 0025044 0025044 00000024743 13543334727 017202 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasq1.f 0000644 0000000 0000000 00000000130 13543334727 015115 x ustar 00 29 mtime=1569569239.01564553
30 atime=1569569239.014645531
29 ctime=1569569239.01564553
elk-6.3.2/src/LAPACK/dlasq1.f 0000644 0025044 0025044 00000015023 13543334727 017167 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgesvd.f 0000644 0000000 0000000 00000000130 13543334727 015232 x ustar 00 29 mtime=1569569239.03164552
30 atime=1569569239.018645529
29 ctime=1569569239.03164552
elk-6.3.2/src/LAPACK/zgesvd.f 0000644 0025044 0025044 00000426453 13543334727 017321 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-6.3.2/src/LAPACK/PaxHeaders.21352/dspev.f 0000644 0000000 0000000 00000000132 13543334727 015053 x ustar 00 30 mtime=1569569239.307645344
30 atime=1569569239.306645345
30 ctime=1569569239.307645344
elk-6.3.2/src/LAPACK/dspev.f 0000644 0025044 0025044 00000017036 13543334727 017131 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief DSPEV 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 DSPEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
*> real symmetric matrix A in packed storage.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the symmetric matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, AP is overwritten by values generated during the
*> reduction to tridiagonal form. If UPLO = 'U', the diagonal
*> and first superdiagonal of the tridiagonal matrix T overwrite
*> the corresponding elements of A, and if UPLO = 'L', the
*> diagonal and first subdiagonal of T overwrite the
*> corresponding elements of A.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (LDZ, N)
*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
*> eigenvectors of the matrix A, with the i-th column of Z
*> holding the eigenvector associated with W(i).
*> If JOBZ = 'N', then Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION 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: 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 doubleOTHEReigen
*
* =====================================================================
SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, 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, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSP( 'M', UPLO, N, AP, 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 ) THEN
CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DOPGTR to generate the orthogonal matrix, then call DSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, 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
*
RETURN
*
* End of DSPEV
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dspevx.f 0000644 0000000 0000000 00000000132 13543334727 015243 x ustar 00 30 mtime=1569569239.312645341
30 atime=1569569239.310645342
30 ctime=1569569239.312645341
elk-6.3.2/src/LAPACK/dspevx.f 0000644 0025044 0025044 00000037043 13543334727 017321 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief DSPEVX 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 DSPEVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
* ABSTOL, M, W, Z, LDZ, WORK, 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 AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSPEVX computes selected eigenvalues and, optionally, eigenvectors
*> of a real symmetric 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the symmetric matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(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 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 (8*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 doubleOTHEReigen
*
* =====================================================================
SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, 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 AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, 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, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ,
$ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC 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( 'DSPEVX', -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.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
M = 1
W( 1 ) = AP( 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
ELSE
VLL = ZERO
VUU = ZERO
END IF
ANRM = DLANSP( 'M', UPLO, N, AP, 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
CALL DSCAL( ( 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 DSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call DSTERF or DOPGTR 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 DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), 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 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, 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.
*
CALL DOPMTR( '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 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
40 CONTINUE
END IF
*
RETURN
*
* End of DSPEVX
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zgees.f 0000644 0000000 0000000 00000000132 13543334727 015047 x ustar 00 30 mtime=1569569239.317645338
30 atime=1569569239.315645339
30 ctime=1569569239.317645338
elk-6.3.2/src/LAPACK/zgees.f 0000644 0025044 0025044 00000032065 13543334727 017124 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEES + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
* LDVS, WORK, LWORK, RWORK, BWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBVS, SORT
* INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
* ..
* .. Array Arguments ..
* LOGICAL BWORK( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
* ..
* .. Function Arguments ..
* LOGICAL SELECT
* EXTERNAL SELECT
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
*> eigenvalues, the Schur form T, and, optionally, the matrix of Schur
*> vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
*>
*> Optionally, it also orders the eigenvalues on the diagonal of the
*> Schur form so that selected eigenvalues are at the top left.
*> The leading columns of Z then form an orthonormal basis for the
*> invariant subspace corresponding to the selected eigenvalues.
*>
*> A complex matrix is in Schur form if it is upper triangular.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBVS
*> \verbatim
*> JOBVS is CHARACTER*1
*> = 'N': Schur vectors are not computed;
*> = 'V': Schur vectors are computed.
*> \endverbatim
*>
*> \param[in] SORT
*> \verbatim
*> SORT is CHARACTER*1
*> Specifies whether or not to order the eigenvalues on the
*> diagonal of the Schur form.
*> = 'N': Eigenvalues are not ordered:
*> = 'S': Eigenvalues are ordered (see SELECT).
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument
*> SELECT must be declared EXTERNAL in the calling subroutine.
*> If SORT = 'S', SELECT is used to select eigenvalues to order
*> to the top left of the Schur form.
*> IF SORT = 'N', SELECT is not referenced.
*> The eigenvalue W(j) is selected if SELECT(W(j)) is true.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N matrix A.
*> On exit, A has been overwritten by its Schur form T.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] SDIM
*> \verbatim
*> SDIM is INTEGER
*> If SORT = 'N', SDIM = 0.
*> If SORT = 'S', SDIM = number of eigenvalues for which
*> SELECT is true.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> W contains the computed eigenvalues, in the same order that
*> they appear on the diagonal of the output Schur form T.
*> \endverbatim
*>
*> \param[out] VS
*> \verbatim
*> VS is COMPLEX*16 array, dimension (LDVS,N)
*> If JOBVS = 'V', VS contains the unitary matrix Z of Schur
*> vectors.
*> If JOBVS = 'N', VS is not referenced.
*> \endverbatim
*>
*> \param[in] LDVS
*> \verbatim
*> LDVS is INTEGER
*> The leading dimension of the array VS. LDVS >= 1; if
*> JOBVS = 'V', LDVS >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,2*N).
*> For good performance, LWORK must generally be larger.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*> BWORK is LOGICAL array, dimension (N)
*> Not referenced if SORT = 'N'.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: if INFO = i, and i is
*> <= N: the QR algorithm failed to compute all the
*> eigenvalues; elements 1:ILO-1 and i+1:N of W
*> contain those eigenvalues which have converged;
*> if JOBVS = 'V', VS contains the matrix which
*> reduces A to its partially converged Schur form.
*> = N+1: the eigenvalues could not be reordered because
*> some eigenvalues were too close to separate (the
*> problem is very ill-conditioned);
*> = N+2: after reordering, roundoff changed values of
*> some complex eigenvalues so that leading
*> eigenvalues in the Schur form no longer satisfy
*> SELECT = .TRUE.. This could also be caused by
*> underflow due to scaling.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEeigen
*
* =====================================================================
SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
$ LDVS, WORK, LWORK, RWORK, BWORK, 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 JOBVS, SORT
INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELECT
EXTERNAL SELECT
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTST, WANTVS
INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
$ ITAU, IWRK, MAXWRK, MINWRK
DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD,
$ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVS = LSAME( JOBVS, 'V' )
WANTST = LSAME( SORT, 'S' )
IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* CWorkspace refers to complex workspace, and RWorkspace to real
* workspace. NB refers to the optimal block size for the
* immediately following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by ZHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
MINWRK = 2*N
*
CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS,
$ WORK, -1, IEVAL )
HSWORK = WORK( 1 )
*
IF( .NOT.WANTVS ) THEN
MAXWRK = MAX( MAXWRK, HSWORK )
ELSE
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
MAXWRK = MAX( MAXWRK, HSWORK )
END IF
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
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 )
*
* Permute the matrix to make it more nearly triangular
* (CWorkspace: none)
* (RWorkspace: need N)
*
IBAL = 1
CALL ZGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: none)
*
ITAU = 1
IWRK = N + ITAU
CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVS ) THEN
*
* Copy Householder vectors to VS
*
CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
* Generate unitary matrix in VS
* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
* (RWorkspace: none)
*
CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
END IF
*
SDIM = 0
*
* Perform QR iteration, accumulating Schur vectors in VS if desired
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS,
$ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
IF( IEVAL.GT.0 )
$ INFO = IEVAL
*
* Sort eigenvalues if desired
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
IF( SCALEA )
$ CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
DO 10 I = 1, N
BWORK( I ) = SELECT( W( I ) )
10 CONTINUE
*
* Reorder eigenvalues and transform Schur vectors
* (CWorkspace: none)
* (RWorkspace: none)
*
CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
$ S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND )
END IF
*
IF( WANTVS ) THEN
*
* Undo balancing
* (CWorkspace: none)
* (RWorkspace: need N)
*
CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS,
$ IERR )
END IF
*
IF( SCALEA ) THEN
*
* Undo scaling for the Schur form of A
*
CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
CALL ZCOPY( N, A, LDA+1, W, 1 )
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of ZGEES
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zgbsv.f 0000644 0000000 0000000 00000000132 13543334727 015065 x ustar 00 30 mtime=1569569239.321645335
30 atime=1569569239.320645336
30 ctime=1569569239.321645335
elk-6.3.2/src/LAPACK/zgbsv.f 0000644 0025044 0025044 00000015566 13543334727 017151 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBSV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBSV computes the solution to a complex system of linear equations
*> A * X = B, where A is a band matrix of order N with KL subdiagonals
*> and KU superdiagonals, and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as A = L * U, where L is a product of permutation
*> and unit lower triangular matrices with KL subdiagonals, and U is
*> upper triangular with KL+KU superdiagonals. The factored form of A
*> is then used to solve the system of equations A * X = B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows KL+1 to
*> 2*KL+KU+1; rows 1 to KL of the array need not be set.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
*> On exit, details of the factorization: U is stored as an
*> upper triangular band matrix with KL+KU superdiagonals in
*> rows 1 to KL+KU+1, and the multipliers used during the
*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*> See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices that define the permutation matrix P;
*> row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and the solution has not been computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GBsolve
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> M = N = 6, KL = 2, KU = 1:
*>
*> On entry: On exit:
*>
*> * * * + + + * * * u14 u25 u36
*> * * + + + + * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
*> a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*>
*> Array elements marked * are not used by the routine; elements marked
*> + need not be set on entry, but are required by the routine to store
*> elements of U because of fill-in resulting from the row interchanges.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (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, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL XERBLA, ZGBTRF, ZGBTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( KL.LT.0 ) THEN
INFO = -2
ELSE IF( KU.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBSV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of the band matrix A.
*
CALL ZGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL ZGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
$ B, LDB, INFO )
END IF
RETURN
*
* End of ZGBSV
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlasq2.f 0000644 0000000 0000000 00000000132 13543334727 015120 x ustar 00 30 mtime=1569569239.326645332
30 atime=1569569239.324645333
30 ctime=1569569239.326645332
elk-6.3.2/src/LAPACK/dlasq2.f 0000644 0025044 0025044 00000041167 13543334727 017200 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorgbr.f 0000644 0000000 0000000 00000000131 13543334727 015210 x ustar 00 30 mtime=1569569239.331645329
29 atime=1569569239.32964533
30 ctime=1569569239.331645329
elk-6.3.2/src/LAPACK/dorgbr.f 0000644 0025044 0025044 00000023230 13543334727 017260 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORGBR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGBR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER VECT
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORGBR generates one of the real orthogonal matrices Q or P**T
*> determined by DGEBRD when reducing a real matrix A to bidiagonal
*> form: A = Q * B * P**T. Q and P**T 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 DORGBR returns the first n
*> columns of Q, where m >= n >= k;
*> if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
*> M-by-M matrix.
*>
*> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
*> is of order N:
*> if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
*> rows of P**T, where n >= m >= k;
*> if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T 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**T is
*> required, as defined in the transformation applied by DGEBRD:
*> = 'Q': generate Q;
*> = 'P': generate P**T.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q or P**T to be returned.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q or P**T 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 DGEBRD.
*> If VECT = 'P', the number of rows in the original K-by-N
*> matrix reduced by DGEBRD.
*> K >= 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 DGEBRD.
*> On exit, the M-by-N matrix Q or P**T.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION 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**T, as
*> returned by DGEBRD in its array argument TAUQ or TAUP.
*> \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,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 doubleGBcomputational
*
* =====================================================================
SUBROUTINE DORGBR( 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 ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTQ
INTEGER I, IINFO, J, LWKOPT, MN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DORGLQ, DORGQR, XERBLA
* ..
* .. 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 DORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
ELSE
IF( M.GT.1 ) THEN
CALL DORGQR( 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 DORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
ELSE
IF( N.GT.1 ) THEN
CALL DORGLQ( 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( 'DORGBR', -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 DGEBRD to reduce an m-by-k
* matrix
*
IF( M.GE.K ) THEN
*
* If m >= k, assume m >= n >= k
*
CALL DORGQR( 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 DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
ELSE
*
* Form P**T, determined by a call to DGEBRD to reduce a k-by-n
* matrix
*
IF( K.LT.N ) THEN
*
* If k < n, assume k <= m <= n
*
CALL DORGLQ( 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**T 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**T(2:n,2:n)
*
CALL DORGLQ( 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 DORGBR
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dgelqf.f 0000644 0000000 0000000 00000000132 13543334727 015174 x ustar 00 30 mtime=1569569239.335645326
30 atime=1569569239.334645327
30 ctime=1569569239.335645326
elk-6.3.2/src/LAPACK/dgelqf.f 0000644 0025044 0025044 00000016604 13543334727 017252 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGELQF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGELQF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGELQF computes an LQ factorization of a real M-by-N matrix A:
*> A = L * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 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,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (min(M,N))
*> 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 >= 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 December 2016
*
*> \ingroup doubleGEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(k) . . . H(2) H(1), where k = min(m,n).
*>
*> 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGELQF( M, 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 ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'DGELQF', ' ', 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( 'DGELQF', -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, 'DGELQF', ' ', 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, 'DGELQF', ' ', 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 DGELQ2( 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 DLARFT( '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 DLARFB( '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 DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of DGELQF
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dorglq.f 0000644 0000000 0000000 00000000132 13543334727 015222 x ustar 00 30 mtime=1569569239.339645324
30 atime=1569569239.338645324
30 ctime=1569569239.339645324
elk-6.3.2/src/LAPACK/dorglq.f 0000644 0025044 0025044 00000017541 13543334727 017301 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORGLQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGLQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGLQ( 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
*>
*> DORGLQ generates an M-by-N real 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(2) H(1)
*>
*> as returned by DGELQF.
*> \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 DOUBLE PRECISION 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 DGELQF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGELQF.
*> \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,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 doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORGLQ( 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, DORGL2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'DORGLQ', ' ', 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( 'DORGLQ', -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, 'DORGLQ', ' ', 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, 'DORGLQ', ' ', 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 DORGL2( 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 DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**T to A(i+ib:m,i:n) from the right
*
CALL DLARFB( 'Right', '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**T to columns i:n of current block
*
CALL DORGL2( 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 DORGLQ
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlange.f 0000644 0000000 0000000 00000000130 13543334727 015162 x ustar 00 29 mtime=1569569239.34464532
30 atime=1569569239.343645321
29 ctime=1569569239.34464532
elk-6.3.2/src/LAPACK/dlange.f 0000644 0025044 0025044 00000013335 13543334727 017240 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLANGE 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 DLANGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLANGE 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 matrix A.
*> \endverbatim
*>
*> \return DLANGE
*> \verbatim
*>
*> DLANGE = ( 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 DLANGE as described
*> above.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0. When M = 0,
*> DLANGE 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,
*> DLANGE is set to zero.
*> \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(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 doubleGEauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLANGE( 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
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, 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 SCALE, SUM, VALUE, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
TEMP = ABS( A( I, J ) )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
TEMP = WORK( I )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANGE = VALUE
RETURN
*
* End of DLANGE
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dbdsqr.f 0000644 0000000 0000000 00000000132 13543334727 015211 x ustar 00 30 mtime=1569569239.350645317
30 atime=1569569239.347645318
30 ctime=1569569239.350645317
elk-6.3.2/src/LAPACK/dbdsqr.f 0000644 0025044 0025044 00000064232 13543334727 017267 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DBDSQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DBDSQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
* LDU, C, LDC, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
* $ VT( LDVT, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DBDSQR 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**T
*>
*> 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**T*VT instead of
*> P**T, for given real input matrices U and VT. When U and VT are the
*> orthogonal matrices that reduce a general matrix A to bidiagonal
*> form: A = U*B*VT, as computed by DGEBRD, then
*>
*> A = (U*Q) * S * (P**T*VT)
*>
*> is the SVD of A. Optionally, the subroutine may also compute Q**T*C
*> for a given real 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 DOUBLE PRECISION array, dimension (LDVT, NCVT)
*> On entry, an N-by-NCVT matrix VT.
*> On exit, VT is overwritten by P**T * 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDC, NCC)
*> On entry, an N-by-NCC matrix C.
*> On exit, C is overwritten by Q**T * 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] 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:
*> if NCVT = NRU = NCC = 0,
*> = 1, a split was marked by a positive value in E
*> = 2, current block of Z not diagonalized after 30*N
*> iterations (in inner while loop)
*> = 3, termination criterion of outer while loop not met
*> (program created more than N unreduced blocks)
*> else NCVT = NRU = NCC = 0,
*> the algorithm did not converge; D and E contain the
*> elements of a bidiagonal matrix which is orthogonally
*> similar to the input matrix B; if INFO = i, i
*> elements of E have not converged to zero.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
*> TOLMUL controls the convergence criterion of the QR loop.
*> If it is positive, TOLMUL*EPS is the desired relative
*> precision in the computed singular values.
*> If it is negative, abs(TOLMUL*EPS*sigma_max) is the
*> desired absolute accuracy in the computed singular
*> values (corresponds to relative accuracy
*> abs(TOLMUL*EPS) in the largest singular value.
*> abs(TOLMUL) should be between 1 and 1/EPS, and preferably
*> between 10 (for fast convergence) and .1/EPS
*> (for there to be some accuracy in the results).
*> Default is to lose at either one eighth or 2 of the
*> available decimal digits in each computed singular value
*> (whichever is smaller).
*>
*> MAXITR INTEGER, default = 6
*> MAXITR controls the maximum number of passes of the
*> algorithm through its inner loop. The algorithms stops
*> (and so fails to converge) if the number of passes
*> through the inner loop exceeds MAXITR*N**2.
*>
*> \endverbatim
*
*> \par Note:
* ===========
*>
*> \verbatim
*> Bug report from Cezary Dendek.
*> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is
*> removed since it can overflow pretty easily (for N larger or equal
*> than 18,919). We instead use MAXITDIVN = MAXITR*N.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, 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 ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION NEGONE
PARAMETER ( NEGONE = -1.0D0 )
DOUBLE PRECISION HNDRTH
PARAMETER ( HNDRTH = 0.01D0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 10.0D0 )
DOUBLE PRECISION HNDRD
PARAMETER ( HNDRD = 100.0D0 )
DOUBLE PRECISION MEIGTH
PARAMETER ( MEIGTH = -0.125D0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M,
$ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM
DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,
$ DSCAL, DSWAP, XERBLA
* ..
* .. 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( 'DBDSQR', -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, WORK, 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 )
WORK( I ) = CS
WORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
$ LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( 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.)
*
MAXITDIVN = MAXITR*N
ITERDIVN = 0
ITER = -1
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
*
IF( ITER.GE.N ) THEN
ITER = ITER - N
ITERDIVN = ITERDIVN + 1
IF( ITERDIVN.GE.MAXITDIVN )
$ GO TO 200
END IF
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
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 DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
$ SINR )
IF( NRU.GT.0 )
$ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL DROT( 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 ) )
WORK( I-LL+1 ) = CS
WORK( I-LL+1+NM1 ) = SN
WORK( I-LL+1+NM12 ) = OLDCS
WORK( 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 DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( 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 ) )
WORK( I-LL ) = CS
WORK( I-LL+NM1 ) = -SN
WORK( I-LL+NM12 ) = OLDCS
WORK( 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 DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( 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
WORK( I-LL+1 ) = COSR
WORK( I-LL+1+NM1 ) = SINR
WORK( I-LL+1+NM12 ) = COSL
WORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( 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
WORK( I-LL ) = COSR
WORK( I-LL+NM1 ) = -SINR
WORK( I-LL+NM12 ) = COSL
WORK( 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 DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( 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 DSCAL( 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 DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL DSWAP( 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 DBDSQR
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dormbr.f 0000644 0000000 0000000 00000000132 13543334727 015217 x ustar 00 30 mtime=1569569239.355645313
30 atime=1569569239.353645315
30 ctime=1569569239.355645313
elk-6.3.2/src/LAPACK/dormbr.f 0000644 0025044 0025044 00000025153 13543334727 017274 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORMBR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORMBR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORMBR( 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 ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> If VECT = 'Q', DORMBR 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
*>
*> If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
*> with
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': P * C C * P
*> TRANS = 'T': P**T * C C * P**T
*>
*> Here Q and P**T are the orthogonal matrices determined by DGEBRD when
*> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
*> P**T 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 orthogonal matrix Q or P**T 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**T;
*> = 'P': apply P or P**T.
*> \endverbatim
*>
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q, Q**T, P or P**T from the Left;
*> = 'R': apply Q, Q**T, P or P**T from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q or P;
*> = 'T': Transpose, apply Q**T or P**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
*> If VECT = 'Q', the number of columns in the original
*> matrix reduced by DGEBRD.
*> If VECT = 'P', the number of rows in the original
*> matrix reduced by DGEBRD.
*> K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DGEBRD.
*> \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 DOUBLE PRECISION 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 DGEBRD in the array argument TAUQ or TAUP.
*> \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
*> or P*C or P**T*C or C*P or C*P**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 (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 DORMBR( 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 ..
DOUBLE PRECISION 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 DORMLQ, DORMQR, XERBLA
* ..
* .. 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( .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, 'T' ) ) 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( APPLYQ ) THEN
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
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMLQ', 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( 'DORMBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
WORK( 1 ) = 1
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 DGEBRD with nq >= k
*
CALL DORMQR( 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 DGEBRD 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 DORMQR( 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 = 'T'
ELSE
TRANST = 'N'
END IF
IF( NQ.GT.K ) THEN
*
* P was determined by a call to DGEBRD with nq > k
*
CALL DORMLQ( 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 DGEBRD 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 DORMLQ( 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 DORMBR
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dlansp.f 0000644 0000000 0000000 00000000132 13543334727 015213 x ustar 00 30 mtime=1569569239.359645311
30 atime=1569569239.358645311
30 ctime=1569569239.359645311
elk-6.3.2/src/LAPACK/dlansp.f 0000644 0025044 0025044 00000017266 13543334727 017276 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLANSP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLANSP 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, supplied in packed form.
*> \endverbatim
*>
*> \return DLANSP
*> \verbatim
*>
*> DLANSP = ( 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 DLANSP as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is supplied.
*> = 'U': Upper triangular part of A is supplied
*> = 'L': Lower triangular part of A is supplied
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, DLANSP is
*> set to zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
*> The upper or lower triangle of the symmetric matrix A, packed
*> columnwise in a linear array. The j-th column of A is stored
*> in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*> WORK is not referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLANSP( 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
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. 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
K = 1
DO 20 J = 1, N
DO 10 I = K, K + J - 1
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
DO 30 I = K, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( AP( K ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( AP( K ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( AP( K ).NE.ZERO ) THEN
ABSA = ABS( AP( K ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANSP = VALUE
RETURN
*
* End of DLANSP
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dsptrd.f 0000644 0000000 0000000 00000000132 13543334727 015232 x ustar 00 30 mtime=1569569239.364645308
30 atime=1569569239.362645309
30 ctime=1569569239.364645308
elk-6.3.2/src/LAPACK/dsptrd.f 0000644 0025044 0025044 00000021160 13543334727 017301 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSPTRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSPTRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSPTRD reduces a real symmetric matrix A stored in packed form 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
*> = '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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the symmetric matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(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 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[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 doubleOTHERcomputational
*
*> \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 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**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 AP,
*> overwriting A(i+2:n,i), and tau is stored in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DSPTRD( 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 AP( * ), 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, I1, I1I1, II
DOUBLE PRECISION ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. 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( 'DSPTRD', -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
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, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
E( I ) = AP( I1+I-1 )
*
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 DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y**T *v) * v
*
ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )
CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**T - w * v**T
*
CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
AP( I1+I-1 ) = E( I )
END IF
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
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v**T
* to annihilate A(i+2:n,i)
*
CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
E( I ) = AP( II+1 )
*
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 DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y**T *v) * v
*
ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ),
$ 1 )
CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**T - w * v**T
*
CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
$ AP( I1I1 ) )
*
AP( II+1 ) = E( I )
END IF
D( I ) = AP( II )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = AP( II )
END IF
*
RETURN
*
* End of DSPTRD
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dopgtr.f 0000644 0000000 0000000 00000000132 13543334727 015231 x ustar 00 30 mtime=1569569239.368645305
30 atime=1569569239.367645306
30 ctime=1569569239.368645305
elk-6.3.2/src/LAPACK/dopgtr.f 0000644 0025044 0025044 00000013667 13543334727 017315 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DOPGTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DOPGTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DOPGTR generates a real orthogonal matrix Q which is defined as the
*> product of n-1 elementary reflectors H(i) of order n, as returned by
*> DSPTRD 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 DSPTRD;
*> = 'L': Lower triangular packed storage used in previous
*> call to DSPTRD.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
*> The vectors which define the elementary reflectors, as
*> returned by DSPTRD.
*> \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 DSPTRD.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is DOUBLE PRECISION array, dimension (LDQ,N)
*> The N-by-N orthogonal 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 DOUBLE PRECISION 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 doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DOPGTR( 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 ..
DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DORG2L, DORG2R, XERBLA
* ..
* .. 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( 'DOPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to DSPTRD 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 ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = ZERO
30 CONTINUE
Q( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to DSPTRD 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 ) = ONE
DO 40 I = 2, N
Q( I, 1 ) = ZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = ZERO
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 DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of DOPGTR
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dopmtr.f 0000644 0000000 0000000 00000000132 13543334727 015237 x ustar 00 30 mtime=1569569239.373645302
30 atime=1569569239.371645303
30 ctime=1569569239.373645302
elk-6.3.2/src/LAPACK/dopmtr.f 0000644 0025044 0025044 00000021014 13543334727 017304 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DOPMTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DOPMTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS, UPLO
* INTEGER INFO, LDC, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DOPMTR 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 DSPTRD 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**T from the Left;
*> = 'R': apply Q or Q**T from the Right.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangular packed storage used in previous
*> call to DSPTRD;
*> = 'L': Lower triangular packed storage used in previous
*> call to DSPTRD.
*> \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] AP
*> \verbatim
*> AP is DOUBLE PRECISION 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 DSPTRD. AP is modified by the routine but
*> restored on exit.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION 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 DSPTRD.
*> \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 DOPMTR( 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 ..
DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, 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' )
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, 'T' ) ) 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( 'DOPMTR', -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 DSPTRD 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) is applied to C(1:i,1:n)
*
MI = I
ELSE
*
* H(i) is applied to C(1:m,1:i)
*
NI = I
END IF
*
* Apply H(i)
*
AII = AP( II )
AP( II ) = ONE
CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), 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 DSPTRD 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) is applied to C(i+1:m,1:n)
*
MI = M - I
IC = I + 1
ELSE
*
* H(i) is applied to C(1:m,i+1:n)
*
NI = N - I
JC = I + 1
END IF
*
* Apply H(i)
*
CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
$ 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 DOPMTR
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zgbtrf.f 0000644 0000000 0000000 00000000130 13543334727 015226 x ustar 00 30 mtime=1569569239.378645299
28 atime=1569569239.3766453
30 ctime=1569569239.378645299
elk-6.3.2/src/LAPACK/zgbtrf.f 0000644 0025044 0025044 00000037710 13543334727 017307 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGBTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
*> using partial pivoting with row interchanges.
*>
*> This is the blocked version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows KL+1 to
*> 2*KL+KU+1; rows 1 to KL of the array need not be set.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*>
*> On exit, details of the factorization: U is stored as an
*> upper triangular band matrix with KL+KU superdiagonals in
*> rows 1 to KL+KU+1, and the multipliers used during the
*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*> See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GBcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> M = N = 6, KL = 2, KU = 1:
*>
*> On entry: On exit:
*>
*> * * * + + + * * * u14 u25 u36
*> * * + + + + * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
*> a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*>
*> Array elements marked * are not used by the routine; elements marked
*> + need not be set on entry, but are required by the routine to store
*> elements of U because of fill-in resulting from the row interchanges.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK computational routine (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, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
$ JU, K2, KM, KV, NB, NW
COMPLEX*16 TEMP
* ..
* .. Local Arrays ..
COMPLEX*16 WORK13( LDWORK, NBMAX ),
$ WORK31( LDWORK, NBMAX )
* ..
* .. External Functions ..
INTEGER ILAENV, IZAMAX
EXTERNAL ILAENV, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP,
$ ZSCAL, ZSWAP, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment
*
NB = ILAENV( 1, 'ZGBTRF', ' ', M, N, KL, KU )
*
* The block size must not exceed the limit set by the size of the
* local arrays WORK13 and WORK31.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KL ) THEN
*
* Use unblocked code
*
CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
ELSE
*
* Use blocked code
*
* Zero the superdiagonal elements of the work array WORK13
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK13( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Zero the subdiagonal elements of the work array WORK31
*
DO 40 J = 1, NB
DO 30 I = J + 1, NB
WORK31( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero
*
DO 60 J = KU + 2, MIN( KV, N )
DO 50 I = KV - J + 2, KL
AB( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
* JU is the index of the last column affected by the current
* stage of the factorization
*
JU = 1
*
DO 180 J = 1, MIN( M, N ), NB
JB = MIN( NB, MIN( M, N )-J+1 )
*
* The active part of the matrix is partitioned
*
* A11 A12 A13
* A21 A22 A23
* A31 A32 A33
*
* Here A11, A21 and A31 denote the current block of JB columns
* which is about to be factorized. The number of rows in the
* partitioning are JB, I2, I3 respectively, and the numbers
* of columns are JB, J2, J3. The superdiagonal elements of A13
* and the subdiagonal elements of A31 lie outside the band.
*
I2 = MIN( KL-JB, M-J-JB+1 )
I3 = MIN( JB, M-J-KL+1 )
*
* J2 and J3 are computed after JU has been updated.
*
* Factorize the current block of JB columns
*
DO 80 JJ = J, J + JB - 1
*
* Set fill-in elements in column JJ+KV to zero
*
IF( JJ+KV.LE.N ) THEN
DO 70 I = 1, KL
AB( I, JJ+KV ) = ZERO
70 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-JJ )
JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 )
IPIV( JJ ) = JP + JJ - J
IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to J+JB-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange affects columns J to JJ-1 of A31
* which are stored in the work array WORK31
*
CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
$ AB( KV+JP, JJ ), LDAB-1 )
END IF
END IF
*
* Compute multipliers
*
CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
$ 1 )
*
* Update trailing submatrix within the band and within
* the current block. JM is the index of the last column
* which needs to be updated.
*
JM = MIN( JU, J+JB-1 )
IF( JM.GT.JJ )
$ CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
$ AB( KV, JJ+1 ), LDAB-1,
$ AB( KV+1, JJ+1 ), LDAB-1 )
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = JJ
END IF
*
* Copy current column of A31 into the work array WORK31
*
NW = MIN( JJ-J+1, I3 )
IF( NW.GT.0 )
$ CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
$ WORK31( 1, JJ-J+1 ), 1 )
80 CONTINUE
IF( J+JB.LE.N ) THEN
*
* Apply the row interchanges to the other blocks.
*
J2 = MIN( JU-J+1, KV ) - JB
J3 = MAX( 0, JU-J-KV+1 )
*
* Use ZLASWP to apply the row interchanges to A12, A22, and
* A32.
*
CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
$ IPIV( J ), 1 )
*
* Adjust the pivot indices.
*
DO 90 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
90 CONTINUE
*
* Apply the row interchanges to A13, A23, and A33
* columnwise.
*
K2 = J - 1 + JB + J2
DO 110 I = 1, J3
JJ = K2 + I
DO 100 II = J + I - 1, J + JB - 1
IP = IPIV( II )
IF( IP.NE.II ) THEN
TEMP = AB( KV+1+II-JJ, JJ )
AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
AB( KV+1+IP-JJ, JJ ) = TEMP
END IF
100 CONTINUE
110 CONTINUE
*
* Update the relevant part of the trailing submatrix
*
IF( J2.GT.0 ) THEN
*
* Update A12
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
$ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1 )
*
IF( I2.GT.0 ) THEN
*
* Update A22
*
CALL ZGEMM( 'No transpose', 'No transpose', I2, J2,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+1, J+JB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A32
*
CALL ZGEMM( 'No transpose', 'No transpose', I3, J2,
$ JB, -ONE, WORK31, LDWORK,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
END IF
END IF
*
IF( J3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array
* WORK13
*
DO 130 JJ = 1, J3
DO 120 II = JJ, JB
WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
120 CONTINUE
130 CONTINUE
*
* Update A13 in the work array
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
$ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
$ WORK13, LDWORK )
*
IF( I2.GT.0 ) THEN
*
* Update A23
*
CALL ZGEMM( 'No transpose', 'No transpose', I2, J3,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
$ LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A33
*
CALL ZGEMM( 'No transpose', 'No transpose', I3, J3,
$ JB, -ONE, WORK31, LDWORK, WORK13,
$ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
END IF
*
* Copy the lower triangle of A13 back into place
*
DO 150 JJ = 1, J3
DO 140 II = JJ, JB
AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
140 CONTINUE
150 CONTINUE
END IF
ELSE
*
* Adjust the pivot indices.
*
DO 160 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
160 CONTINUE
END IF
*
* Partially undo the interchanges in the current block to
* restore the upper triangular form of A31 and copy the upper
* triangle of A31 back into place
*
DO 170 JJ = J + JB - 1, J, -1
JP = IPIV( JJ ) - JJ + 1
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to JJ-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
* The interchange does not affect A31
*
CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange does affect A31
*
CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
END IF
END IF
*
* Copy the current column of A31 back into place
*
NW = MIN( I3, JJ-J+1 )
IF( NW.GT.0 )
$ CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
$ AB( KV+KL+1-JJ+J, JJ ), 1 )
170 CONTINUE
180 CONTINUE
END IF
*
RETURN
*
* End of ZGBTRF
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zgbtrs.f 0000644 0000000 0000000 00000000132 13543334727 015245 x ustar 00 30 mtime=1569569239.383645295
30 atime=1569569239.381645297
30 ctime=1569569239.383645295
elk-6.3.2/src/LAPACK/zgbtrs.f 0000644 0025044 0025044 00000020347 13543334727 017322 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGBTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBTRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBTRS solves a system of linear equations
*> A * X = B, A**T * X = B, or A**H * X = B
*> with a general band matrix A using the LU factorization computed
*> by ZGBTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the form of the system of equations.
*> = 'N': A * X = B (No transpose)
*> = 'T': A**T * X = B (Transpose)
*> = 'C': A**H * X = B (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> Details of the LU factorization of the band matrix A, as
*> computed by ZGBTRF. U is stored as an upper triangular band
*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
*> the multipliers used during the factorization are stored in
*> rows KL+KU+2 to 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= N, row i of the matrix was
*> interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GBcomputational
*
* =====================================================================
SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LNOTI, NOTRAN
INTEGER I, J, KD, L, LM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP, ZTBSV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
KD = KU + KL + 1
LNOTI = KL.GT.0
*
IF( NOTRAN ) THEN
*
* Solve A*X = B.
*
* Solve L*X = B, overwriting B with X.
*
* L is represented as a product of permutations and unit lower
* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
* where each transformation L(i) is a rank-one modification of
* the identity matrix.
*
IF( LNOTI ) THEN
DO 10 J = 1, N - 1
LM = MIN( KL, N-J )
L = IPIV( J )
IF( L.NE.J )
$ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
$ LDB, B( J+1, 1 ), LDB )
10 CONTINUE
END IF
*
DO 20 I = 1, NRHS
*
* Solve U*X = B, overwriting B with X.
*
CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
$ AB, LDAB, B( 1, I ), 1 )
20 CONTINUE
*
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Solve A**T * X = B.
*
DO 30 I = 1, NRHS
*
* Solve U**T * X = B, overwriting B with X.
*
CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
$ LDAB, B( 1, I ), 1 )
30 CONTINUE
*
* Solve L**T * X = B, overwriting B with X.
*
IF( LNOTI ) THEN
DO 40 J = N - 1, 1, -1
LM = MIN( KL, N-J )
CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
$ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
L = IPIV( J )
IF( L.NE.J )
$ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
40 CONTINUE
END IF
*
ELSE
*
* Solve A**H * X = B.
*
DO 50 I = 1, NRHS
*
* Solve U**H * X = B, overwriting B with X.
*
CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
$ KL+KU, AB, LDAB, B( 1, I ), 1 )
50 CONTINUE
*
* Solve L**H * X = B, overwriting B with X.
*
IF( LNOTI ) THEN
DO 60 J = N - 1, 1, -1
LM = MIN( KL, N-J )
CALL ZLACGV( NRHS, B( J, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE,
$ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE,
$ B( J, 1 ), LDB )
CALL ZLACGV( NRHS, B( J, 1 ), LDB )
L = IPIV( J )
IF( L.NE.J )
$ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
60 CONTINUE
END IF
END IF
RETURN
*
* End of ZGBTRS
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/ztrsen.f 0000644 0000000 0000000 00000000132 13543334727 015257 x ustar 00 30 mtime=1569569239.388645292
30 atime=1569569239.386645294
30 ctime=1569569239.388645292
elk-6.3.2/src/LAPACK/ztrsen.f 0000644 0025044 0025044 00000033103 13543334727 017326 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRSEN
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRSEN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
* SEP, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPQ, JOB
* INTEGER INFO, LDQ, LDT, LWORK, M, N
* DOUBLE PRECISION S, SEP
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSEN reorders the Schur factorization of a complex matrix
*> A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
*> the leading positions on the diagonal of the upper triangular matrix
*> T, and the leading columns of Q form an orthonormal basis of the
*> corresponding right invariant subspace.
*>
*> Optionally the routine computes the reciprocal condition numbers of
*> the cluster of eigenvalues and/or the invariant subspace.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies whether condition numbers are required for the
*> cluster of eigenvalues (S) or the invariant subspace (SEP):
*> = 'N': none;
*> = 'E': for eigenvalues only (S);
*> = 'V': for invariant subspace only (SEP);
*> = 'B': for both eigenvalues and invariant subspace (S and
*> SEP).
*> \endverbatim
*>
*> \param[in] COMPQ
*> \verbatim
*> COMPQ is CHARACTER*1
*> = 'V': update the matrix Q of Schur vectors;
*> = 'N': do not update Q.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> SELECT specifies the eigenvalues in the selected cluster. To
*> select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,N)
*> On entry, the upper triangular matrix T.
*> On exit, T is overwritten by the reordered matrix T, with the
*> selected eigenvalues as the leading diagonal elements.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
*> On exit, if COMPQ = 'V', Q has been postmultiplied by the
*> unitary transformation matrix which reorders T; the leading M
*> columns of Q form an orthonormal basis for the specified
*> invariant subspace.
*> If COMPQ = 'N', Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q.
*> LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The reordered eigenvalues of T, in the same order as they
*> appear on the diagonal of T.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The dimension of the specified invariant subspace.
*> 0 <= M <= N.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION
*> If JOB = 'E' or 'B', S is a lower bound on the reciprocal
*> condition number for the selected cluster of eigenvalues.
*> S cannot underestimate the true reciprocal condition number
*> by more than a factor of sqrt(N). If M = 0 or N, S = 1.
*> If JOB = 'N' or 'V', S is not referenced.
*> \endverbatim
*>
*> \param[out] SEP
*> \verbatim
*> SEP is DOUBLE PRECISION
*> If JOB = 'V' or 'B', SEP is the estimated reciprocal
*> condition number of the specified invariant subspace. If
*> M = 0 or N, SEP = norm(T).
*> If JOB = 'N' or 'E', SEP is not referenced.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If JOB = 'N', LWORK >= 1;
*> if JOB = 'E', LWORK = max(1,M*(N-M));
*> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> ZTRSEN first collects the selected eigenvalues by computing a unitary
*> transformation Z to move them to the top left corner of T. In other
*> words, the selected eigenvalues are the eigenvalues of T11 in:
*>
*> Z**H * T * Z = ( T11 T12 ) n1
*> ( 0 T22 ) n2
*> n1 n2
*>
*> where N = n1+n2. The first
*> n1 columns of Z span the specified invariant subspace of T.
*>
*> If T has been obtained from the Schur factorization of a matrix
*> A = Q*T*Q**H, then the reordered Schur factorization of A is given by
*> A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the
*> corresponding invariant subspace of A.
*>
*> The reciprocal condition number of the average of the eigenvalues of
*> T11 may be returned in S. S lies between 0 (very badly conditioned)
*> and 1 (very well conditioned). It is computed as follows. First we
*> compute R so that
*>
*> P = ( I R ) n1
*> ( 0 0 ) n2
*> n1 n2
*>
*> is the projector on the invariant subspace associated with T11.
*> R is the solution of the Sylvester equation:
*>
*> T11*R - R*T22 = T12.
*>
*> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
*> the two-norm of M. Then S is computed as the lower bound
*>
*> (1 + F-norm(R)**2)**(-1/2)
*>
*> on the reciprocal of 2-norm(P), the true reciprocal condition number.
*> S cannot underestimate 1 / 2-norm(P) by more than a factor of
*> sqrt(N).
*>
*> An approximate error bound for the computed average of the
*> eigenvalues of T11 is
*>
*> EPS * norm(T) / S
*>
*> where EPS is the machine precision.
*>
*> The reciprocal condition number of the right invariant subspace
*> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
*> SEP is defined as the separation of T11 and T22:
*>
*> sep( T11, T22 ) = sigma-min( C )
*>
*> where sigma-min(C) is the smallest singular value of the
*> n1*n2-by-n1*n2 matrix
*>
*> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
*>
*> I(m) is an m by m identity matrix, and kprod denotes the Kronecker
*> product. We estimate sigma-min(C) by the reciprocal of an estimate of
*> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
*> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
*>
*> When SEP is small, small changes in T can cause large changes in
*> the invariant subspace. An approximate bound on the maximum angular
*> error in the computed right invariant subspace is
*>
*> EPS * norm(T) / SEP
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
$ SEP, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (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, JOB
INTEGER INFO, LDQ, LDT, LWORK, M, N
DOUBLE PRECISION S, SEP
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP
INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN
DOUBLE PRECISION EST, RNORM, SCALE
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION ZLANGE
EXTERNAL LSAME, ZLANGE
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
WANTQ = LSAME( COMPQ, 'V' )
*
* Set M to the number of selected eigenvalues.
*
M = 0
DO 10 K = 1, N
IF( SELECT( K ) )
$ M = M + 1
10 CONTINUE
*
N1 = M
N2 = N - M
NN = N1*N2
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
*
IF( WANTSP ) THEN
LWMIN = MAX( 1, 2*NN )
ELSE IF( LSAME( JOB, 'N' ) ) THEN
LWMIN = 1
ELSE IF( LSAME( JOB, 'E' ) ) THEN
LWMIN = MAX( 1, NN )
END IF
*
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTS )
$ S = ONE
IF( WANTSP )
$ SEP = ZLANGE( '1', N, N, T, LDT, RWORK )
GO TO 40
END IF
*
* Collect the selected eigenvalues at the top left corner of T.
*
KS = 0
DO 20 K = 1, N
IF( SELECT( K ) ) THEN
KS = KS + 1
*
* Swap the K-th eigenvalue to position KS.
*
IF( K.NE.KS )
$ CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR )
END IF
20 CONTINUE
*
IF( WANTS ) THEN
*
* Solve the Sylvester equation for R:
*
* T11*R - R*T22 = scale*T12
*
CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
$ LDT, WORK, N1, SCALE, IERR )
*
* Estimate the reciprocal of the condition number of the cluster
* of eigenvalues.
*
RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK )
IF( RNORM.EQ.ZERO ) THEN
S = ONE
ELSE
S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
$ SQRT( RNORM ) )
END IF
END IF
*
IF( WANTSP ) THEN
*
* Estimate sep(T11,T22).
*
EST = ZERO
KASE = 0
30 CONTINUE
CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve T11*R - R*T22 = scale*X.
*
CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
ELSE
*
* Solve T11**H*R - R*T22**H = scale*X.
*
CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
END IF
GO TO 30
END IF
*
SEP = SCALE / EST
END IF
*
40 CONTINUE
*
* Copy reordered eigenvalues to W.
*
DO 50 K = 1, N
W( K ) = T( K, K )
50 CONTINUE
*
WORK( 1 ) = LWMIN
*
RETURN
*
* End of ZTRSEN
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zgeqrf.f 0000644 0000000 0000000 00000000127 13543334727 015234 x ustar 00 29 mtime=1569569239.39264529
29 atime=1569569239.39164529
29 ctime=1569569239.39264529
elk-6.3.2/src/LAPACK/zgeqrf.f 0000644 0025044 0025044 00000016635 13543334727 017312 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.
*> \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 December 2016
*
*> \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.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, 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgebrd.f 0000644 0000000 0000000 00000000132 13543334727 015207 x ustar 00 30 mtime=1569569239.397645286
30 atime=1569569239.396645287
30 ctime=1569569239.397645286
elk-6.3.2/src/LAPACK/zgebrd.f 0000644 0025044 0025044 00000025740 13543334727 017266 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-6.3.2/src/LAPACK/PaxHeaders.21352/zungbr.f 0000644 0000000 0000000 00000000132 13543334727 015241 x ustar 00 30 mtime=1569569239.402645283
30 atime=1569569239.400645285
30 ctime=1569569239.402645283
elk-6.3.2/src/LAPACK/zungbr.f 0000644 0025044 0025044 00000023266 13543334727 017321 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgelqf.f 0000644 0000000 0000000 00000000132 13543334727 015222 x ustar 00 30 mtime=1569569239.406645281
30 atime=1569569239.405645281
30 ctime=1569569239.406645281
elk-6.3.2/src/LAPACK/zgelqf.f 0000644 0025044 0025044 00000016613 13543334727 017300 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 * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and below the diagonal of the array
*> contain the m-by-min(m,n) lower trapezoidal matrix L (L is
*> lower triangular if m <= n); the elements above the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,M).
*> For optimum performance LWORK >= M*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \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.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, 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunglq.f 0000644 0000000 0000000 00000000132 13543334727 015252 x ustar 00 30 mtime=1569569239.411645278
30 atime=1569569239.410645278
30 ctime=1569569239.411645278
elk-6.3.2/src/LAPACK/zunglq.f 0000644 0025044 0025044 00000017565 13543334727 017337 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-6.3.2/src/LAPACK/PaxHeaders.21352/zbdsqr.f 0000644 0000000 0000000 00000000132 13543334727 015237 x ustar 00 30 mtime=1569569239.417645274
30 atime=1569569239.414645276
30 ctime=1569569239.417645274
elk-6.3.2/src/LAPACK/zbdsqr.f 0000644 0025044 0025044 00000062517 13543334727 017321 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunmbr.f 0000644 0000000 0000000 00000000132 13543334727 015247 x ustar 00 30 mtime=1569569239.422645271
30 atime=1569569239.420645272
30 ctime=1569569239.422645271
elk-6.3.2/src/LAPACK/zunmbr.f 0000644 0025044 0025044 00000025553 13543334727 017330 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasv2.f 0000644 0000000 0000000 00000000132 13543334727 015125 x ustar 00 30 mtime=1569569239.426645268
30 atime=1569569239.425645269
30 ctime=1569569239.426645268
elk-6.3.2/src/LAPACK/dlasv2.f 0000644 0025044 0025044 00000020451 13543334727 017176 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlas2.f 0000644 0000000 0000000 00000000132 13543334727 014737 x ustar 00 30 mtime=1569569239.430645265
30 atime=1569569239.429645266
30 ctime=1569569239.430645265
elk-6.3.2/src/LAPACK/dlas2.f 0000644 0025044 0025044 00000011753 13543334727 017015 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlabrd.f 0000644 0000000 0000000 00000000132 13543334727 015162 x ustar 00 30 mtime=1569569239.435645262
30 atime=1569569239.433645264
30 ctime=1569569239.435645262
elk-6.3.2/src/LAPACK/dlabrd.f 0000644 0025044 0025044 00000033043 13543334727 017234 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLABRD 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 DLABRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLABRD( 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 A( LDA, * ), D( * ), E( * ), TAUP( * ),
* $ TAUQ( * ), X( LDX, * ), Y( LDY, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLABRD reduces the first NB rows and columns of a real general
*> m by n matrix A to upper or lower bidiagonal form by an orthogonal
*> transformation Q**T * 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 DGEBRD
*> \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 DOUBLE PRECISION 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 orthogonal
*> matrix Q as a product of elementary reflectors; and
*> elements above the diagonal in the first NB rows, with the
*> array TAUP, represent the orthogonal 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 orthogonal
*> 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 orthogonal 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 DOUBLE PRECISION array, dimension (NB)
*> The scalar factors of the elementary reflectors which
*> represent the orthogonal matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is DOUBLE PRECISION array, dimension (NB)
*> The scalar factors of the elementary reflectors which
*> represent the orthogonal matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 doubleOTHERauxiliary
*
*> \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**T and G(i) = I - taup * u * u**T
*>
*> where tauq and taup are real scalars, and v and u are real 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**T 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**T - X*U**T.
*>
*> 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 DLABRD( 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 A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), X( LDX, * ), Y( LDY, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLARFG, DSCAL
* ..
* .. 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 DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
CALL DGEMV( '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)
*
CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
$ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
$ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
$ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
$ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
*
* Update A(i,i+1:n)
*
CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
$ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
*
* Generate reflection P(i) to annihilate A(i,i+2:n)
*
CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
$ LDA, TAUP( I ) )
E( I ) = A( I, I+1 )
A( I, I+1 ) = ONE
*
* Compute X(i+1:m,i)
*
CALL DGEMV( '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 DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
$ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, NB
*
* Update A(i,i:n)
*
CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
$ X( I, 1 ), LDX, ONE, A( I, I ), LDA )
*
* Generate reflection P(i) to annihilate A(i,i+1:n)
*
CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = A( I, I )
IF( I.LT.M ) THEN
A( I, I ) = ONE
*
* Compute X(i+1:m,i)
*
CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
$ A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
*
* Update A(i+1:m,i)
*
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
CALL DGEMV( '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)
*
CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
$ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
$ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
END IF
20 CONTINUE
END IF
RETURN
*
* End of DLABRD
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dgebd2.f 0000644 0000000 0000000 00000000131 13543334727 015060 x ustar 00 30 mtime=1569569239.440645259
29 atime=1569569239.43964526
30 ctime=1569569239.440645259
elk-6.3.2/src/LAPACK/dgebd2.f 0000644 0025044 0025044 00000023450 13543334727 017134 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGEBD2 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 DGEBD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
* $ TAUQ( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEBD2 reduces a real general m by n matrix A to upper or lower
*> bidiagonal form B by an orthogonal transformation: Q**T * 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 DOUBLE PRECISION 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 orthogonal matrix Q as a product of elementary
*> reflectors, and the elements above the first superdiagonal,
*> with the array TAUP, represent the orthogonal 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 orthogonal matrix Q as a product of
*> elementary reflectors, and the elements above the diagonal,
*> with the array TAUP, represent the orthogonal 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 DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the orthogonal matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the orthogonal matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION 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 doubleGEcomputational
*
*> \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**T and G(i) = I - taup * u * u**T
*>
*> where tauq and taup are real scalars, and v and u are real 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**T and G(i) = I - taup * u * u**T
*>
*> where tauq and taup are real scalars, and v and u are real 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 DGEBD2( 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 A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFG, 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.LT.0 ) THEN
CALL XERBLA( 'DGEBD2', -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)
*
CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = A( I, I )
A( I, I ) = ONE
*
* Apply H(i) to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
$ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, 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 DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
$ LDA, TAUP( I ) )
E( I ) = A( I, I+1 )
A( I, I+1 ) = ONE
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
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 DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = A( I, I )
A( I, I ) = ONE
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
$ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.M ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Apply H(i) to A(i+1:m,i+1:n) from the left
*
CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, 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 DGEBD2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dgelq2.f 0000644 0000000 0000000 00000000132 13543334727 015110 x ustar 00 30 mtime=1569569239.444645257
30 atime=1569569239.443645257
30 ctime=1569569239.444645257
elk-6.3.2/src/LAPACK/dgelq2.f 0000644 0025044 0025044 00000012021 13543334727 017153 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGELQ2 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 DGELQ2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGELQ2 computes an LQ factorization of a real m by n matrix A:
*> A = L * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 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,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION 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 December 2016
*
*> \ingroup doubleGEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(k) . . . H(2) H(1), where k = min(m,n).
*>
*> 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGELQ2( M, N, 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, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFG, XERBLA
* ..
* .. 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( 'DGELQ2', -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 DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAU( I ) )
IF( I.LT.M ) THEN
*
* Apply H(i) to A(i+1:m,i:n) from the right
*
AII = A( I, I )
A( I, I ) = ONE
CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
$ A( I+1, I ), LDA, WORK )
A( I, I ) = AII
END IF
10 CONTINUE
RETURN
*
* End of DGELQ2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dgeqr2.f 0000644 0000000 0000000 00000000132 13543334727 015116 x ustar 00 30 mtime=1569569239.449645253
30 atime=1569569239.448645254
30 ctime=1569569239.449645253
elk-6.3.2/src/LAPACK/dgeqr2.f 0000644 0025044 0025044 00000012012 13543334727 017161 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGEQR2 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 DGEQR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEQR2 computes a QR factorization of a real m by n matrix A:
*> A = Q * R.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 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,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \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 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
*
*> \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**T
*>
*> where tau is a real scalar, and v is a real 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 DGEQR2( M, N, 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, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFG, XERBLA
* ..
* .. 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( 'DGEQR2', -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 DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAU( I ) )
IF( I.LT.N ) THEN
*
* Apply H(i) to A(i:m,i+1:n) from the left
*
AII = A( I, I )
A( I, I ) = ONE
CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
A( I, I ) = AII
END IF
10 CONTINUE
RETURN
*
* End of DGEQR2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dorgl2.f 0000644 0000000 0000000 00000000132 13543334727 015123 x ustar 00 30 mtime=1569569239.453645251
30 atime=1569569239.452645251
30 ctime=1569569239.453645251
elk-6.3.2/src/LAPACK/dorgl2.f 0000644 0025044 0025044 00000012173 13543334727 017176 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORGL2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGL2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGL2( 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
*>
*> DORGL2 generates an m by n real 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(2) H(1)
*>
*> as returned by DGELQF.
*> \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 DOUBLE PRECISION 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 DGELQF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGELQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION 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 doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORGL2( 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.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( 'DORGL2', -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) to A(i:m,i:n) from the right
*
IF( I.LT.N ) THEN
IF( I.LT.M ) THEN
A( I, I ) = ONE
CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAU( I ), A( I+1, I ), LDA, WORK )
END IF
CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
END IF
A( I, I ) = ONE - 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 DORGL2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dormlq.f 0000644 0000000 0000000 00000000132 13543334727 015230 x ustar 00 30 mtime=1569569239.458645248
30 atime=1569569239.456645249
30 ctime=1569569239.458645248
elk-6.3.2/src/LAPACK/dormlq.f 0000644 0025044 0025044 00000022502 13543334727 017300 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORMLQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORMLQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORMLQ( 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
*>
*> DORMLQ 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 DGELQF. 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,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
*> DGELQF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGELQF.
*> \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 DORMLQ( 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
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 DLARFB, DLARFT, DORML2, 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, 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, 'DORMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB + TSIZE
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMLQ', -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, 'DORMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL DORML2( 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 = 'T'
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 DLARFT( 'Forward', 'Rowwise', 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, 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 DORMLQ
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zgbtf2.f 0000644 0000000 0000000 00000000132 13543334727 015130 x ustar 00 30 mtime=1569569239.462645245
30 atime=1569569239.461645246
30 ctime=1569569239.462645245
elk-6.3.2/src/LAPACK/zgbtf2.f 0000644 0025044 0025044 00000017674 13543334727 017216 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBTF2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
*> A using partial pivoting with row interchanges.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows KL+1 to
*> 2*KL+KU+1; rows 1 to KL of the array need not be set.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*>
*> On exit, details of the factorization: U is stored as an
*> upper triangular band matrix with KL+KU superdiagonals in
*> rows 1 to KL+KU+1, and the multipliers used during the
*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*> See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GBcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> M = N = 6, KL = 2, KU = 1:
*>
*> On entry: On exit:
*>
*> * * * + + + * * * u14 u25 u36
*> * * + + + + * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
*> a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*>
*> Array elements marked * are not used by the routine; elements marked
*> + need not be set on entry, but are required by the routine to store
*> elements of U, because of fill-in resulting from the row
*> interchanges.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK computational routine (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, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, JP, JU, KM, KV
* ..
* .. External Functions ..
INTEGER IZAMAX
EXTERNAL IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in.
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero.
*
DO 20 J = KU + 2, MIN( KV, N )
DO 10 I = KV - J + 2, KL
AB( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* JU is the index of the last column affected by the current stage
* of the factorization.
*
JU = 1
*
DO 40 J = 1, MIN( M, N )
*
* Set fill-in elements in column J+KV to zero.
*
IF( J+KV.LE.N ) THEN
DO 30 I = 1, KL
AB( I, J+KV ) = ZERO
30 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-J )
JP = IZAMAX( KM+1, AB( KV+1, J ), 1 )
IPIV( J ) = JP + J - 1
IF( AB( KV+JP, J ).NE.ZERO ) THEN
JU = MAX( JU, MIN( J+KU+JP-1, N ) )
*
* Apply interchange to columns J to JU.
*
IF( JP.NE.1 )
$ CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
$ AB( KV+1, J ), LDAB-1 )
IF( KM.GT.0 ) THEN
*
* Compute multipliers.
*
CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
*
* Update trailing submatrix within the band.
*
IF( JU.GT.J )
$ CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1,
$ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
$ LDAB-1 )
END IF
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = J
END IF
40 CONTINUE
RETURN
*
* End of ZGBTF2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zlabrd.f 0000644 0000000 0000000 00000000132 13543334727 015210 x ustar 00 30 mtime=1569569239.467645242
30 atime=1569569239.465645243
30 ctime=1569569239.467645242
elk-6.3.2/src/LAPACK/zlabrd.f 0000644 0025044 0025044 00000035767 13543334727 017301 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgebd2.f 0000644 0000000 0000000 00000000132 13543334727 015107 x ustar 00 30 mtime=1569569239.472645239
30 atime=1569569239.471645239
30 ctime=1569569239.472645239
elk-6.3.2/src/LAPACK/zgebd2.f 0000644 0025044 0025044 00000024303 13543334727 017160 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-6.3.2/src/LAPACK/PaxHeaders.21352/zgelq2.f 0000644 0000000 0000000 00000000132 13543334727 015136 x ustar 00 30 mtime=1569569239.476645236
30 atime=1569569239.475645237
30 ctime=1569569239.476645236
elk-6.3.2/src/LAPACK/zgelq2.f 0000644 0025044 0025044 00000012204 13543334727 017204 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 * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, the elements on and below the diagonal of the array
*> contain the m by min(m,n) lower trapezoidal matrix L (L is
*> lower triangular if m <= n); the elements above the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \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.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 ..
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-6.3.2/src/LAPACK/PaxHeaders.21352/zgeqr2.f 0000644 0000000 0000000 00000000132 13543334727 015144 x ustar 00 30 mtime=1569569239.481645233
30 atime=1569569239.480645234
30 ctime=1569569239.481645233
elk-6.3.2/src/LAPACK/zgeqr2.f 0000644 0025044 0025044 00000012050 13543334727 017211 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.
*> \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 December 2016
*
*> \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.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 ..
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-6.3.2/src/LAPACK/PaxHeaders.21352/ztrsyl.f 0000644 0000000 0000000 00000000130 13543334727 015277 x ustar 00 29 mtime=1569569239.48664523
30 atime=1569569239.484645231
29 ctime=1569569239.48664523
elk-6.3.2/src/LAPACK/ztrsyl.f 0000644 0025044 0025044 00000032567 13543334727 017365 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRSYL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRSYL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
* LDC, SCALE, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANA, TRANB
* INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSYL solves the complex Sylvester matrix equation:
*>
*> op(A)*X + X*op(B) = scale*C or
*> op(A)*X - X*op(B) = scale*C,
*>
*> where op(A) = A or A**H, and A and B are both upper triangular. A is
*> M-by-M and B is N-by-N; the right hand side C and the solution X are
*> M-by-N; and scale is an output scale factor, set <= 1 to avoid
*> overflow in X.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANA
*> \verbatim
*> TRANA is CHARACTER*1
*> Specifies the option op(A):
*> = 'N': op(A) = A (No transpose)
*> = 'C': op(A) = A**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] TRANB
*> \verbatim
*> TRANB is CHARACTER*1
*> Specifies the option op(B):
*> = 'N': op(B) = B (No transpose)
*> = 'C': op(B) = B**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] ISGN
*> \verbatim
*> ISGN is INTEGER
*> Specifies the sign in the equation:
*> = +1: solve op(A)*X + X*op(B) = scale*C
*> = -1: solve op(A)*X - X*op(B) = scale*C
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The order of the matrix A, and the number of rows in the
*> matrices X and C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix B, and the number of columns in the
*> matrices X and C. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,M)
*> The upper triangular matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
*> The upper triangular matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N right hand side matrix C.
*> On exit, C is overwritten by the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M)
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> The scale factor, scale, set <= 1 to avoid overflow in X.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> = 1: A and B have common or very close eigenvalues; perturbed
*> values were used to solve the equation (but the matrices
*> A and B are unchanged).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16SYcomputational
*
* =====================================================================
SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
$ LDC, SCALE, 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 TRANA, TRANB
INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRNA, NOTRNB
INTEGER J, K, L
DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
$ SMLNUM
COMPLEX*16 A11, SUML, SUMR, VEC, X11
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANGE
COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, XERBLA, ZDSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test input parameters
*
NOTRNA = LSAME( TRANA, 'N' )
NOTRNB = LSAME( TRANB, 'N' )
*
INFO = 0
IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN
INFO = -2
ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRSYL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
SCALE = ONE
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM*DBLE( M*N ) / EPS
BIGNUM = ONE / SMLNUM
SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ),
$ EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) )
SGN = ISGN
*
IF( NOTRNA .AND. NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* M L-1
* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
* I=K+1 J=1
*
DO 30 L = 1, N
DO 20 K = M, 1, -1
*
SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
$ C( MIN( K+1, M ), L ), 1 )
SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
VEC = C( K, L ) - ( SUML+SGN*SUMR )
*
SCALOC = ONE
A11 = A( K, K ) + SGN*B( L, L )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 10 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
10 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
20 CONTINUE
30 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
*
* Solve A**H *X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* upper-left corner column by column by
*
* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1 L-1
* R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
* I=1 J=1
*
DO 60 L = 1, N
DO 50 K = 1, M
*
SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
VEC = C( K, L ) - ( SUML+SGN*SUMR )
*
SCALOC = ONE
A11 = DCONJG( A( K, K ) ) + SGN*B( L, L )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 40 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
40 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
50 CONTINUE
60 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A**H*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* upper-right corner column by column by
*
* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1
* R(K,L) = SUM [A**H(I,K)*X(I,L)] +
* I=1
* N
* ISGN*SUM [X(K,J)*B**H(L,J)].
* J=L+1
*
DO 90 L = N, 1, -1
DO 80 K = 1, M
*
SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = DCONJG( A( K, K )+SGN*B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 70 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
80 CONTINUE
90 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
* I=K+1 J=L+1
*
DO 120 L = N, 1, -1
DO 110 K = M, 1, -1
*
SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
$ C( MIN( K+1, M ), L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = A( K, K ) + SGN*DCONJG( B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
110 CONTINUE
120 CONTINUE
*
END IF
*
RETURN
*
* End of ZTRSYL
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zlacn2.f 0000644 0000000 0000000 00000000132 13543334727 015123 x ustar 00 30 mtime=1569569239.490645227
30 atime=1569569239.489645228
30 ctime=1569569239.490645227
elk-6.3.2/src/LAPACK/zlacn2.f 0000644 0025044 0025044 00000017454 13543334727 017205 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACN2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
*
* .. Scalar Arguments ..
* INTEGER KASE, N
* DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
* INTEGER ISAVE( 3 )
* COMPLEX*16 V( * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACN2 estimates the 1-norm of a square, complex matrix A.
*> Reverse communication is used for evaluating matrix-vector products.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 1.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (N)
*> On the final return, V = A*W, where EST = norm(V)/norm(W)
*> (W is not returned).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (N)
*> On an intermediate return, X should be overwritten by
*> A * X, if KASE=1,
*> A**H * X, if KASE=2,
*> where A**H is the conjugate transpose of A, and ZLACN2 must be
*> re-called with all the other parameters unchanged.
*> \endverbatim
*>
*> \param[in,out] EST
*> \verbatim
*> EST is DOUBLE PRECISION
*> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
*> unchanged from the previous call to ZLACN2.
*> On exit, EST is an estimate (a lower bound) for norm(A).
*> \endverbatim
*>
*> \param[in,out] KASE
*> \verbatim
*> KASE is INTEGER
*> On the initial call to ZLACN2, KASE should be 0.
*> On an intermediate return, KASE will be 1 or 2, indicating
*> whether X should be overwritten by A * X or A**H * X.
*> On the final return from ZLACN2, KASE will again be 0.
*> \endverbatim
*>
*> \param[in,out] ISAVE
*> \verbatim
*> ISAVE is INTEGER array, dimension (3)
*> ISAVE is used to save variables between calls to ZLACN2
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Originally named CONEST, dated March 16, 1988.
*>
*> Last modified: April, 1999
*>
*> This is a thread safe version of ZLACON, which uses the array ISAVE
*> in place of a SAVE statement, as follows:
*>
*> ZLACON ZLACN2
*> JUMP ISAVE(1)
*> J ISAVE(2)
*> ITER ISAVE(3)
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> Nick Higham, University of Manchester
*
*> \par References:
* ================
*>
*> N.J. Higham, "FORTRAN codes for estimating the one-norm of
*> a real or complex matrix, with applications to condition estimation",
*> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*>
* =====================================================================
SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
*
* -- LAPACK auxiliary routine (version 3.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 KASE, N
DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
INTEGER ISAVE( 3 )
COMPLEX*16 V( * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
INTEGER I, JLAST
DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
* ..
* .. External Functions ..
INTEGER IZMAX1
DOUBLE PRECISION DLAMCH, DZSUM1
EXTERNAL IZMAX1, DLAMCH, DZSUM1
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'Safe minimum' )
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = DCMPLX( ONE / DBLE( N ) )
10 CONTINUE
KASE = 1
ISAVE( 1 ) = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 )
*
* ................ ENTRY (ISAVE( 1 ) = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 130
END IF
EST = DZSUM1( N, X, 1 )
*
DO 30 I = 1, N
ABSXI = ABS( X( I ) )
IF( ABSXI.GT.SAFMIN ) THEN
X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
$ DIMAG( X( I ) ) / ABSXI )
ELSE
X( I ) = CONE
END IF
30 CONTINUE
KASE = 2
ISAVE( 1 ) = 2
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
*
40 CONTINUE
ISAVE( 2 ) = IZMAX1( N, X, 1 )
ISAVE( 3 ) = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = CZERO
60 CONTINUE
X( ISAVE( 2 ) ) = CONE
KASE = 1
ISAVE( 1 ) = 3
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL ZCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = DZSUM1( N, V, 1 )
*
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 100
*
DO 80 I = 1, N
ABSXI = ABS( X( I ) )
IF( ABSXI.GT.SAFMIN ) THEN
X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
$ DIMAG( X( I ) ) / ABSXI )
ELSE
X( I ) = CONE
END IF
80 CONTINUE
KASE = 2
ISAVE( 1 ) = 4
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 4)
* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
*
90 CONTINUE
JLAST = ISAVE( 2 )
ISAVE( 2 ) = IZMAX1( N, X, 1 )
IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
$ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
ISAVE( 3 ) = ISAVE( 3 ) + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
100 CONTINUE
ALTSGN = ONE
DO 110 I = 1, N
X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) )
ALTSGN = -ALTSGN
110 CONTINUE
KASE = 1
ISAVE( 1 ) = 5
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
120 CONTINUE
TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL ZCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
130 CONTINUE
KASE = 0
RETURN
*
* End of ZLACN2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zungl2.f 0000644 0000000 0000000 00000000132 13543334727 015153 x ustar 00 30 mtime=1569569239.495645224
30 atime=1569569239.494645225
30 ctime=1569569239.495645224
elk-6.3.2/src/LAPACK/zungl2.f 0000644 0025044 0025044 00000012645 13543334727 017232 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-6.3.2/src/LAPACK/PaxHeaders.21352/zunmlq.f 0000644 0000000 0000000 00000000132 13543334727 015260 x ustar 00 30 mtime=1569569239.499645221
30 atime=1569569239.498645222
30 ctime=1569569239.499645221
elk-6.3.2/src/LAPACK/zunmlq.f 0000644 0025044 0025044 00000022503 13543334727 017331 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-6.3.2/src/LAPACK/PaxHeaders.21352/dorml2.f 0000644 0000000 0000000 00000000132 13543334727 015131 x ustar 00 30 mtime=1569569239.504645218
30 atime=1569569239.502645219
30 ctime=1569569239.504645218
elk-6.3.2/src/LAPACK/dorml2.f 0000644 0025044 0025044 00000016355 13543334727 017212 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORML2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORML2( 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
*>
*> DORML2 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 DGELQF. 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,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
*> DGELQF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGELQF.
*> \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 DORML2( 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORML2', -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) 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 ), LDA, TAU( I ),
$ C( IC, JC ), LDC, WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of DORML2
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/dzsum1.f 0000644 0000000 0000000 00000000132 13543334727 015155 x ustar 00 30 mtime=1569569239.508645216
30 atime=1569569239.507645216
30 ctime=1569569239.508645216
elk-6.3.2/src/LAPACK/dzsum1.f 0000644 0025044 0025044 00000006342 13543334727 017231 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DZSUM1 forms the 1-norm of the complex vector using the true absolute value.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DZSUM1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DZSUM1 takes the sum of the absolute values of a complex
*> vector and returns a double precision result.
*>
*> Based on DZASUM from the Level 1 BLAS.
*> The change is to use the 'genuine' absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vector CX.
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX*16 array, dimension (N)
*> The vector whose elements will be summed.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive values of CX. INCX > 0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Nick Higham for use with ZLACON.
*
* =====================================================================
DOUBLE PRECISION FUNCTION DZSUM1( N, CX, 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 CX( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, NINCX
DOUBLE PRECISION STEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
DZSUM1 = 0.0D0
STEMP = 0.0D0
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 )
$ GO TO 20
*
* CODE FOR INCREMENT NOT EQUAL TO 1
*
NINCX = N*INCX
DO 10 I = 1, NINCX, INCX
*
* NEXT LINE MODIFIED.
*
STEMP = STEMP + ABS( CX( I ) )
10 CONTINUE
DZSUM1 = STEMP
RETURN
*
* CODE FOR INCREMENT EQUAL TO 1
*
20 CONTINUE
DO 30 I = 1, N
*
* NEXT LINE MODIFIED.
*
STEMP = STEMP + ABS( CX( I ) )
30 CONTINUE
DZSUM1 = STEMP
RETURN
*
* End of DZSUM1
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/izmax1.f 0000644 0000000 0000000 00000000132 13543334727 015143 x ustar 00 30 mtime=1569569239.512645213
30 atime=1569569239.511645214
30 ctime=1569569239.512645213
elk-6.3.2/src/LAPACK/izmax1.f 0000644 0025044 0025044 00000006623 13543334727 017221 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b IZMAX1 finds the index of the first vector element of maximum absolute value.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IZMAX1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION IZMAX1( N, ZX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IZMAX1 finds the index of the first vector element of maximum absolute value.
*>
*> Based on IZAMAX from Level 1 BLAS.
*> The change is to use the 'genuine' absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vector ZX.
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension (N)
*> The vector ZX. The IZMAX1 function returns the index of its first
*> element of maximum absolute value.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive values of ZX. INCX >= 1.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date February 2014
*
*> \ingroup complexOTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Nick Higham for use with ZLACON.
*
* =====================================================================
INTEGER FUNCTION IZMAX1( N, ZX, 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..--
* February 2014
*
* .. Scalar Arguments ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DMAX
INTEGER I, IX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IZMAX1 = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
IZMAX1 = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DMAX = ABS(ZX(1))
DO I = 2,N
IF (ABS(ZX(I)).GT.DMAX) THEN
IZMAX1 = I
DMAX = ABS(ZX(I))
END IF
END DO
ELSE
*
* code for increment not equal to 1
*
IX = 1
DMAX = ABS(ZX(1))
IX = IX + INCX
DO I = 2,N
IF (ABS(ZX(IX)).GT.DMAX) THEN
IZMAX1 = I
DMAX = ABS(ZX(IX))
END IF
IX = IX + INCX
END DO
END IF
RETURN
*
* End of IZMAX1
*
END
elk-6.3.2/src/LAPACK/PaxHeaders.21352/zunml2.f 0000644 0000000 0000000 00000000132 13543334727 015161 x ustar 00 30 mtime=1569569239.516645211
30 atime=1569569239.515645211
30 ctime=1569569239.516645211
elk-6.3.2/src/LAPACK/zunml2.f 0000644 0025044 0025044 00000017050 13543334727 017233 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasq5.f 0000644 0000000 0000000 00000000132 13543334727 015123 x ustar 00 30 mtime=1569569239.521645207
30 atime=1569569239.519645209
30 ctime=1569569239.521645207
elk-6.3.2/src/LAPACK/dlasq5.f 0000644 0025044 0025044 00000026255 13543334727 017204 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-6.3.2/src/LAPACK/PaxHeaders.21352/dlasq6.f 0000644 0000000 0000000 00000000132 13543334727 015124 x ustar 00 30 mtime=1569569239.525645205
30 atime=1569569239.524645205
30 ctime=1569569239.525645205
elk-6.3.2/src/LAPACK/dlasq6.f 0000644 0025044 0025044 00000015214 13543334727 017176 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-6.3.2/src/PaxHeaders.21352/fftlib 0000644 0000000 0000000 00000000132 13543334727 014021 x ustar 00 30 mtime=1569569239.539645196
30 atime=1569569239.535645198
30 ctime=1569569239.539645196
elk-6.3.2/src/fftlib/ 0000755 0025044 0025044 00000000000 13543334727 016145 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/src/fftlib/PaxHeaders.21352/Makefile 0000644 0000000 0000000 00000000132 13543334727 015536 x ustar 00 30 mtime=1569569239.537645197
30 atime=1569569239.536645198
30 ctime=1569569239.537645197
elk-6.3.2/src/fftlib/Makefile 0000644 0025044 0025044 00000001075 13543334727 017610 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-6.3.2/src/fftlib/PaxHeaders.21352/cfftnd.f90 0000644 0000000 0000000 00000000132 13543334727 015662 x ustar 00 30 mtime=1569569239.546645191
30 atime=1569569239.540645195
30 ctime=1569569239.546645191
elk-6.3.2/src/fftlib/cfftnd.f90 0000644 0025044 0025044 00000164174 13543334727 017746 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-6.3.2/src/PaxHeaders.21352/eos 0000644 0000000 0000000 00000000132 13543334727 013341 x ustar 00 30 mtime=1569569239.613645149
30 atime=1569569239.556645185
30 ctime=1569569239.613645149
elk-6.3.2/src/eos/ 0000755 0025044 0025044 00000000000 13543334727 015465 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/src/eos/PaxHeaders.21352/Makefile 0000644 0000000 0000000 00000000132 13543334727 015056 x ustar 00 30 mtime=1569569239.558645184
30 atime=1569569239.557645184
30 ctime=1569569239.558645184
elk-6.3.2/src/eos/Makefile 0000644 0025044 0025044 00000001346 13543334727 017131 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-6.3.2/src/eos/PaxHeaders.21352/README 0000644 0000000 0000000 00000000132 13543334727 014276 x ustar 00 30 mtime=1569569239.569645177
30 atime=1569569239.561645182
30 ctime=1569569239.569645177
elk-6.3.2/src/eos/README 0000644 0025044 0025044 00000002544 13543334727 016352 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-6.3.2/src/eos/PaxHeaders.21352/eos.f90 0000644 0000000 0000000 00000000132 13543334727 014524 x ustar 00 30 mtime=1569569239.573645174
30 atime=1569569239.572645175
30 ctime=1569569239.573645174
elk-6.3.2/src/eos/eos.f90 0000644 0025044 0025044 00000000517 13543334727 016576 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-6.3.2/src/eos/PaxHeaders.21352/eos.in 0000644 0000000 0000000 00000000132 13543334727 014534 x ustar 00 30 mtime=1569569239.581645169
30 atime=1569569239.576645172
30 ctime=1569569239.581645169
elk-6.3.2/src/eos/eos.in 0000644 0025044 0025044 00000000635 13543334727 016607 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-6.3.2/src/eos/PaxHeaders.21352/eveos.f90 0000644 0000000 0000000 00000000132 13543334727 015057 x ustar 00 30 mtime=1569569239.585645167
30 atime=1569569239.584645167
30 ctime=1569569239.585645167
elk-6.3.2/src/eos/eveos.f90 0000644 0025044 0025044 00000004556 13543334727 017140 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-6.3.2/src/eos/PaxHeaders.21352/fitdata.f90 0000644 0000000 0000000 00000000132 13543334727 015352 x ustar 00 30 mtime=1569569239.588645165
30 atime=1569569239.587645165
30 ctime=1569569239.588645165
elk-6.3.2/src/eos/fitdata.f90 0000644 0025044 0025044 00000001732 13543334727 017424 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-6.3.2/src/eos/PaxHeaders.21352/fmin_nm.f90 0000644 0000000 0000000 00000000132 13543334727 015361 x ustar 00 30 mtime=1569569239.592645162
30 atime=1569569239.591645163
30 ctime=1569569239.592645162
elk-6.3.2/src/eos/fmin_nm.f90 0000644 0025044 0025044 00000000746 13543334727 017437 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-6.3.2/src/eos/PaxHeaders.21352/getedata.f90 0000644 0000000 0000000 00000000127 13543334727 015520 x ustar 00 29 mtime=1569569239.59664516
29 atime=1569569239.59564516
29 ctime=1569569239.59664516
elk-6.3.2/src/eos/getedata.f90 0000644 0025044 0025044 00000003251 13543334727 017564 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-6.3.2/src/eos/PaxHeaders.21352/minf_nm.f90 0000644 0000000 0000000 00000000132 13543334727 015361 x ustar 00 30 mtime=1569569239.599645158
30 atime=1569569239.599645158
30 ctime=1569569239.599645158
elk-6.3.2/src/eos/minf_nm.f90 0000644 0025044 0025044 00000003712 13543334727 017433 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-6.3.2/src/eos/PaxHeaders.21352/modmain.f90 0000644 0000000 0000000 00000000132 13543334727 015362 x ustar 00 30 mtime=1569569239.603645155
30 atime=1569569239.602645156
30 ctime=1569569239.603645155
elk-6.3.2/src/eos/modmain.f90 0000644 0025044 0025044 00000002762 13543334727 017440 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-6.3.2/src/eos/PaxHeaders.21352/output.f90 0000644 0000000 0000000 00000000132 13543334727 015276 x ustar 00 30 mtime=1569569239.607645153
30 atime=1569569239.606645153
30 ctime=1569569239.607645153
elk-6.3.2/src/eos/output.f90 0000644 0025044 0025044 00000005056 13543334727 017353 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-6.3.2/src/eos/PaxHeaders.21352/pveos.f90 0000644 0000000 0000000 00000000130 13543334727 015070 x ustar 00 29 mtime=1569569239.61164515
30 atime=1569569239.610645151
29 ctime=1569569239.61164515
elk-6.3.2/src/eos/pveos.f90 0000644 0025044 0025044 00000000661 13543334727 017144 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-6.3.2/src/eos/PaxHeaders.21352/readinput.f90 0000644 0000000 0000000 00000000132 13543334727 015731 x ustar 00 30 mtime=1569569239.614645148
30 atime=1569569239.614645148
30 ctime=1569569239.614645148
elk-6.3.2/src/eos/readinput.f90 0000644 0025044 0025044 00000001440 13543334727 017777 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-6.3.2/src/PaxHeaders.21352/spacegroup 0000644 0000000 0000000 00000000132 13543334730 014715 x ustar 00 30 mtime=1569569240.052644868
30 atime=1569569239.625645141
30 ctime=1569569240.052644868
elk-6.3.2/src/spacegroup/ 0000755 0025044 0025044 00000000000 13543334730 017041 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-6.3.2/src/spacegroup/PaxHeaders.21352/Makefile 0000644 0000000 0000000 00000000127 13543334727 016444 x ustar 00 29 mtime=1569569239.62764514
29 atime=1569569239.62664514
29 ctime=1569569239.62764514
elk-6.3.2/src/spacegroup/Makefile 0000644 0025044 0025044 00000002161 13543334727 020507 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 $(EXE)
doc:
../protex -s $(SRC_main) $(SRC_modules) $(SRC_routines) > spacegroup.tex
pdflatex spacegroup;pdflatex spacegroup;pdflatex spacegroup
spaces:
../rmspaces $(SRC)
elk-6.3.2/src/spacegroup/PaxHeaders.21352/findprimcell.f90 0000644 0000000 0000000 00000000132 13543334727 017770 x ustar 00 30 mtime=1569569239.631645137
30 atime=1569569239.630645138
30 ctime=1569569239.631645137
elk-6.3.2/src/spacegroup/findprimcell.f90 0000644 0025044 0025044 00000007356 13543334727 022052 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-6.3.2/src/spacegroup/PaxHeaders.21352/gencrystal.f90 0000644 0000000 0000000 00000000132 13543334727 017473 x ustar 00 30 mtime=1569569239.635645135
30 atime=1569569239.634645135
30 ctime=1569569239.635645135
elk-6.3.2/src/spacegroup/gencrystal.f90 0000644 0025044 0025044 00000005773 13543334727 021556 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-6.3.2/src/spacegroup/PaxHeaders.21352/gengroup.f90 0000644 0000000 0000000 00000000132 13543334727 017146 x ustar 00 30 mtime=1569569239.638645133
30 atime=1569569239.637645133
30 ctime=1569569239.638645133
elk-6.3.2/src/spacegroup/gengroup.f90 0000644 0025044 0025044 00000003317 13543334727 021221 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-6.3.2/src/spacegroup/PaxHeaders.21352/geomplot.f90 0000644 0000000 0000000 00000000130 13543334727 017144 x ustar 00 29 mtime=1569569239.64264513
30 atime=1569569239.641645131
29 ctime=1569569239.64264513
elk-6.3.2/src/spacegroup/geomplot.f90 0000644 0025044 0025044 00000004453 13543334727 021223 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-6.3.2/src/spacegroup/PaxHeaders.21352/main.f90 0000644 0000000 0000000 00000000132 13543334727 016244 x ustar 00 30 mtime=1569569239.649645126
30 atime=1569569239.645645128
30 ctime=1569569239.649645126
elk-6.3.2/src/spacegroup/main.f90 0000644 0025044 0025044 00000132676 13543334727 020332 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-6.3.2/src/spacegroup/PaxHeaders.21352/modmain.f90 0000644 0000000 0000000 00000000132 13543334727 016744 x ustar 00 30 mtime=1569569239.653645123
30 atime=1569569239.652645124
30 ctime=1569569239.653645123
elk-6.3.2/src/spacegroup/modmain.f90 0000644 0025044 0025044 00000004543 13543334727 021021 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-6.3.2/src/spacegroup/PaxHeaders.21352/r3cross.f90 0000644 0000000 0000000 00000000132 13543334727 016716 x ustar 00 30 mtime=1569569239.657645121
30 atime=1569569239.656645121
30 ctime=1569569239.657645121
elk-6.3.2/src/spacegroup/r3cross.f90 0000644 0025044 0025044 00000001373 13543334727 020771 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-6.3.2/src/spacegroup/PaxHeaders.21352/r3frac.f90 0000644 0000000 0000000 00000000132 13543334727 016500 x ustar 00 30 mtime=1569569239.661645118
30 atime=1569569239.660645119
30 ctime=1569569239.661645118
elk-6.3.2/src/spacegroup/r3frac.f90 0000644 0025044 0025044 00000001760 13543334727 020553 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-6.3.2/src/spacegroup/PaxHeaders.21352/r3minv.f90 0000644 0000000 0000000 00000000132 13543334727 016536 x ustar 00 30 mtime=1569569239.664645116
30 atime=1569569239.663645117
30 ctime=1569569239.664645116
elk-6.3.2/src/spacegroup/r3minv.f90 0000644 0025044 0025044 00000002362 13543334727 020610 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-6.3.2/src/spacegroup/PaxHeaders.21352/r3mm.f90 0000644 0000000 0000000 00000000132 13543334727 016176 x ustar 00 30 mtime=1569569239.668645114
30 atime=1569569239.667645114
30 ctime=1569569239.668645114
elk-6.3.2/src/spacegroup/r3mm.f90 0000644 0025044 0025044 00000002135 13543334727 020246 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-6.3.2/src/spacegroup/PaxHeaders.21352/r3mv.f90 0000644 0000000 0000000 00000000132 13543334727 016207 x ustar 00 30 mtime=1569569239.672645111
30 atime=1569569239.671645112
30 ctime=1569569239.672645111
elk-6.3.2/src/spacegroup/r3mv.f90 0000644 0025044 0025044 00000001437 13543334727 020263 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-6.3.2/src/spacegroup/PaxHeaders.21352/readinput.f90 0000644 0000000 0000000 00000000132 13543334727 017313 x ustar 00 30 mtime=1569569239.675645109
30 atime=1569569239.675645109
30 ctime=1569569239.675645109
elk-6.3.2/src/spacegroup/readinput.f90 0000644 0025044 0025044 00000003003 13543334727 021356 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-6.3.2/src/spacegroup/PaxHeaders.21352/seitzeq.f90 0000644 0000000 0000000 00000000132 13543334727 017004 x ustar 00 30 mtime=1569569239.679645107
30 atime=1569569239.678645107
30 ctime=1569569239.679645107
elk-6.3.2/src/spacegroup/seitzeq.f90 0000644 0025044 0025044 00000001271 13543334727 021054 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-6.3.2/src/spacegroup/PaxHeaders.21352/seitzgen.f90 0000644 0000000 0000000 00000000132 13543334727 017150 x ustar 00 30 mtime=1569569239.684645103
30 atime=1569569239.682645105
30 ctime=1569569239.684645103
elk-6.3.2/src/spacegroup/seitzgen.f90 0000644 0025044 0025044 00000025667 13543334727 021237 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-6.3.2/src/spacegroup/PaxHeaders.21352/seitzmul.f90 0000644 0000000 0000000 00000000132 13543334727 017174 x ustar 00 30 mtime=1569569239.687645101
30 atime=1569569239.687645101
30 ctime=1569569239.687645101
elk-6.3.2/src/spacegroup/seitzmul.f90 0000644 0025044 0025044 00000001123 13543334727 021240 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-6.3.2/src/spacegroup/PaxHeaders.21352/sgsymb.f90 0000644 0000000 0000000 00000000132 13543334727 016624 x ustar 00 30 mtime=1569569239.694645097
30 atime=1569569239.690645099
30 ctime=1569569239.694645097
elk-6.3.2/src/spacegroup/sgsymb.f90 0000644 0025044 0025044 00000100400 13543334727 020666 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-6.3.2/src/spacegroup/PaxHeaders.21352/spacegroup.in 0000644 0000000 0000000 00000000132 13543334730 017472 x ustar 00 30 mtime=1569569240.045644873
30 atime=1569569239.697645095
30 ctime=1569569240.045644873
elk-6.3.2/src/spacegroup/spacegroup.in 0000644 0025044 0025044 00000001030 13543334730 021533 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, spfname
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-6.3.2/src/spacegroup/PaxHeaders.21352/spacegroup.out 0000644 0000000 0000000 00000000130 13543334730 017671 x ustar 00 29 mtime=1569569240.04964487
30 atime=1569569240.048644871
29 ctime=1569569240.04964487
elk-6.3.2/src/spacegroup/spacegroup.out 0000644 0025044 0025044 00000001620 13543334730 021741 0 ustar 00dewhurst dewhurst 0000000 0000000 \BOOKMARK [1][-]{section.1}{Introduction}{}% 1
\BOOKMARK [1][-]{section.2}{Usage}{}% 2
\BOOKMARK [1][-]{section.3}{Table of space group symbols}{}% 3
\BOOKMARK [1][-]{section.4}{Routine/Function Prologues}{}% 4
\BOOKMARK [2][-]{subsection.4.1}{Fortran: Module Interface modmain \(Source File: modmain.f90\)}{section.4}% 5
\BOOKMARK [2][-]{subsection.4.2}{sgsymb \(Source File: sgsymb.f90\)}{section.4}% 6
\BOOKMARK [2][-]{subsection.4.3}{findprimcell \(Source File: findprimcell.f90\)}{section.4}% 7
\BOOKMARK [2][-]{subsection.4.4}{r3frac \(Source File: r3frac.f90\)}{section.4}% 8
\BOOKMARK [2][-]{subsection.4.5}{r3mv \(Source File: r3mv.f90\)}{section.4}% 9
\BOOKMARK [2][-]{subsection.4.6}{r3cross \(Source File: r3cross.f90\)}{section.4}% 10
\BOOKMARK [2][-]{subsection.4.7}{r3minv \(Source File: r3minv.f90\)}{section.4}% 11
\BOOKMARK [2][-]{subsection.4.8}{r3mm \(Source File: r3mm.f90\)}{section.4}% 12
elk-6.3.2/src/spacegroup/PaxHeaders.21352/writegeom.f90 0000644 0000000 0000000 00000000132 13543334730 017314 x ustar 00 30 mtime=1569569240.053644868
30 atime=1569569240.053644868
30 ctime=1569569240.053644868
elk-6.3.2/src/spacegroup/writegeom.f90 0000644 0025044 0025044 00000003346 13543334730 021371 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-6.3.2/src/PaxHeaders.21352/modmain.f90 0000644 0000000 0000000 00000000131 13543334734 014571 x ustar 00 30 mtime=1569569244.199642219
29 atime=1569569240.06564486
30 ctime=1569569244.199642219
elk-6.3.2/src/modmain.f90 0000644 0025044 0025044 00000120167 13543334734 016650 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
!----------------------------------!
! 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)
! number of coarse radial mesh points to nuclear radius
integer nrcnucl(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(:,:)
! r^l on radial mesh to muffin-tin radius
real(8), allocatable :: rlsp(:,:,:)
! 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 integration on coarse radial mesh
real(8), allocatable :: wrcmt(:,:)
! weights for spline partial integration on coarse radial mesh
real(8), allocatable :: wprcmt(:,:,:)
! maximum allowable angular momentum for augmented plane waves
integer, parameter :: maxlapw=50
! 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)
! index to (l,m) pairs
integer, allocatable :: idxlm(:,:)
! inverse index to (l,m) pairs
integer, allocatable :: idxil(:),idxim(:)
! 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
! 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 ngdc(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)
! corners of box in lattice coordinates containing the k-points, the zeroth
! vector is the origin
real(8) kptboxl(3,0: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 (i1,i2,i3) to reduced k-point index
integer, allocatable :: ivkik(:,:,:)
! map from (i1,i2,i3) 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
!------------------------------!
! 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
! map from non-reduced grid to reduced index
integer, allocatable :: iqmap(:,:,:)
! map from non-reduced grid to non-reduced index
integer, allocatable :: iqmapnr(:,:,:)
! locations of q-points on integer grid
integer, allocatable :: ivq(:,:)
! map from (i1,i2,i3) to q-vector index
integer, allocatable :: ivqiq(:,:,:)
! 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
! index of q = 0 point
integer iq0
! regularised Coulomb Green's function in q-space
real(8), allocatable :: gclq(:)
!-----------------------------------------------------!
! spherical harmonic transform (SHT) matrices !
!-----------------------------------------------------!
! trotsht is .true. if the spherical cover used for the SHT is to be rotated
logical trotsht
data 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(:,:)
! tcden is .true. if the current density is to be calculated
logical tcden
! muffin-tin and interstitial current density vector field
real(8), allocatable :: cdmt(:,:,:),cdir(:,:)
! 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(:)
! constant part of exchange-correlation potential
real(8) vxc0
! muffin-tin and interstitial Kohn-Sham effective potential
real(8), allocatable :: vsmt(:,:),vsir(:)
! G-space interstitial Kohn-Sham effective potential
complex(8), allocatable :: vsig(:)
! 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
! muffin-tin Kohn-Sham effective magnetic field in spherical coordinates and on
! a coarse radial mesh
real(8), allocatable :: bsmt(:,:,:)
! interstitial Kohn-Sham effective magnetic field
real(8), allocatable :: bsir(:,:)
! nosource is .true. if the field is to be made source-free
logical nosource
! tssxc is .true. if scaled spin exchange-correlation (SSXC) is to be used
logical tssxc
! SSXC scaling factor
real(8) ssxc
! 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 tau-DFT functional
logical taudft
! tau-DFT exchange-correlation potential
real(8), allocatable :: wxcmt(:,:),wxcir(:)
! tau-DFT 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
! temperature in degrees Kelvin
real(8) tempk
! maximum number of iterations used for inverting the Kohn-Sham equations
integer maxitksi
! step size used for inverting the Kohn-Sham equations
real(8) tauksi
!--------------------------!
! 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 current
real(8) curtot(3)
! total current magnitude
real(8) curtotm
!-----------------------------------------!
! 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
! type of eigenvalue solver to be used
integer evtype
!--------------------------------------------!
! 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 and stress 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
data 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
real(8) tauoep
! 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
! 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
complex(8), allocatable :: zil(:),zilc(:)
! Pauli spin matrices:
! sigma_x = ( 0 1 ) sigma_y = ( 0 -i ) sigma_z = ( 1 0 )
! ( 1 0 ) ( i 0 ) ( 0 -1 )
complex(8) sigmat(2,2,3)
data sigmat / (0.d0,0.d0), (1.d0,0.d0), (1.d0,0.d0), (0.d0,0.d0), &
(0.d0,0.d0), (0.d0,1.d0),(0.d0,-1.d0), (0.d0,0.d0), &
(1.d0,0.d0), (0.d0,0.d0), (0.d0,0.d0),(-1.d0,0.d0) /
! 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 version(3)
data version / 6,3,2 /
! 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
! if wrtvars is .true. then variables are written to VARIABLES.OUT
logical wrtvars
! filename extension for files generated by gndstate
character(256) filext
! default file extension
data 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-6.3.2/src/PaxHeaders.21352/mpi_stub.f90 0000644 0000000 0000000 00000000132 13543334737 014773 x ustar 00 30 mtime=1569569247.241640276
30 atime=1569569240.073644855
30 ctime=1569569247.241640276
elk-6.3.2/src/mpi_stub.f90 0000644 0025044 0025044 00000003620 13543334737 017043 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
return
end subroutine
subroutine mpi_finalize(ierror)
implicit none
integer, intent(out) :: ierror
ierror=0
return
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
return
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
return
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
return
end subroutine
subroutine mpi_barrier(comm,ierror)
implicit none
integer, intent(in) :: comm
integer, intent(out) :: ierror
ierror=0
return
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
return
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
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/modmpi.f90 0000644 0000000 0000000 00000000132 13543334734 014433 x ustar 00 30 mtime=1569569244.208642214
30 atime=1569569240.077644852
30 ctime=1569569244.208642214
elk-6.3.2/src/modmpi.f90 0000644 0025044 0025044 00000000742 13543334734 016505 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-6.3.2/src/PaxHeaders.21352/libxcifc_stub.f90 0000644 0000000 0000000 00000000131 13543334737 015770 x ustar 00 30 mtime=1569569247.287640247
29 atime=1569569240.08164485
30 ctime=1569569247.287640247
elk-6.3.2/src/libxcifc_stub.f90 0000644 0025044 0025044 00000004163 13543334737 020044 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-6.3.2/src/PaxHeaders.21352/modxcifc.f90 0000644 0000000 0000000 00000000132 13543334734 014742 x ustar 00 30 mtime=1569569244.218642207
30 atime=1569569240.085644847
30 ctime=1569569244.218642207
elk-6.3.2/src/modxcifc.f90 0000644 0025044 0025044 00000041020 13543334734 017006 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(:,1),ra(:,1),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(:,1),ra(:,1),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(:,1),ra(:,1),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
return
case(2)
xcdescr='Perdew-Zunger/Ceperley-Alder, Phys. Rev. B 23, 5048 (1981)'
xcspin=0
xcgrad=0
return
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
return
end subroutine
!EOC
end module
elk-6.3.2/src/PaxHeaders.21352/modfxcifc.f90 0000644 0000000 0000000 00000000132 13543334734 015110 x ustar 00 30 mtime=1569569244.222642205
30 atime=1569569240.343644682
30 ctime=1569569244.222642205
elk-6.3.2/src/modfxcifc.f90 0000644 0025044 0025044 00000004127 13543334734 017163 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-6.3.2/src/PaxHeaders.21352/moddftu.f90 0000644 0000000 0000000 00000000131 13543334734 014607 x ustar 00 30 mtime=1569569244.226642202
29 atime=1569569240.34764468
30 ctime=1569569244.226642202
elk-6.3.2/src/moddftu.f90 0000644 0025044 0025044 00000006277 13543334734 016673 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-6.3.2/src/PaxHeaders.21352/modrdm.f90 0000644 0000000 0000000 00000000126 13543334734 014433 x ustar 00 28 mtime=1569569244.2306422
30 atime=1569569240.352644677
28 ctime=1569569244.2306422
elk-6.3.2/src/modrdm.f90 0000644 0025044 0025044 00000002132 13543334734 016475 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-6.3.2/src/PaxHeaders.21352/modphonon.f90 0000644 0000000 0000000 00000000132 13543334734 015147 x ustar 00 30 mtime=1569569244.235642196
30 atime=1569569240.356644674
30 ctime=1569569244.235642196
elk-6.3.2/src/modphonon.f90 0000644 0025044 0025044 00000010702 13543334734 017216 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
!-----------------------------!
! 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
data tphdyn / .false. /
! nuclear potential without the self-term; used for the phonon dynamical matrix
complex(8), allocatable :: zvnmt(:)
! Kohn-Sham potential derivative
complex(8), allocatable :: dvsmt(:,:),dvsir(:)
! gradient of vsmt for the displaced muffin-tin
complex(8), allocatable :: gvsmt(:)
! G+q-space interstitial Kohn-Sham potential derivative
complex(8), allocatable :: dvsig(:)
! Kohn-Sham effective magnetic field derivative
complex(8), allocatable :: dbsmt(:,:,:),dbsir(:,:)
! 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(:,:)
end module
elk-6.3.2/src/PaxHeaders.21352/modscdft.f90 0000644 0000000 0000000 00000000132 13543334734 014751 x ustar 00 30 mtime=1569569244.239642194
30 atime=1569569240.360644671
30 ctime=1569569244.239642194
elk-6.3.2/src/modscdft.f90 0000644 0025044 0025044 00000001355 13543334734 017024 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 modscdft
! number of normal Kohn-Sham states to use in the BdG equations
integer nbdg
! size of the BdG matrix (2*nbdg)
integer nmbdg
! maximum energy around the Fermi energy containing the BdG states
real(8) emaxbdg
! index from the BdG states to the normal second-variational states
integer, allocatable :: idxbdg(:,:)
! eigenvalues of the BdG Hamiltonian
real(8), allocatable :: evalbdg(:)
! BdG inversion algorithm mixing parameter
real(8) taubdg
! magnitude of random numbers used to initialise the anomalous density
real(8) rndachi
end module
elk-6.3.2/src/PaxHeaders.21352/modtest.f90 0000644 0000000 0000000 00000000132 13543334734 014625 x ustar 00 30 mtime=1569569244.243642191
30 atime=1569569240.364644669
30 ctime=1569569244.243642191
elk-6.3.2/src/modtest.f90 0000644 0025044 0025044 00000004672 13543334734 016705 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')
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_)
return
end subroutine
end module
elk-6.3.2/src/PaxHeaders.21352/modrandom.f90 0000644 0000000 0000000 00000000132 13543334734 015126 x ustar 00 30 mtime=1569569244.248642188
30 atime=1569569240.369644666
30 ctime=1569569244.248642188
elk-6.3.2/src/modrandom.f90 0000644 0025044 0025044 00000002546 13543334734 017204 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)
data rndstate / 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,i1,i5
data i / 0 /
!$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-6.3.2/src/PaxHeaders.21352/modstore.f90 0000644 0000000 0000000 00000000132 13543334734 015002 x ustar 00 30 mtime=1569569244.252642186
30 atime=1569569240.373644663
30 ctime=1569569244.252642186
elk-6.3.2/src/modstore.f90 0000644 0025044 0025044 00000002104 13543334734 017046 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) 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_
end module
elk-6.3.2/src/PaxHeaders.21352/modpw.f90 0000644 0000000 0000000 00000000132 13543334734 014274 x ustar 00 30 mtime=1569569244.256642183
30 atime=1569569240.377644661
30 ctime=1569569244.256642183
elk-6.3.2/src/modpw.f90 0000644 0025044 0025044 00000003202 13543334734 016340 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-6.3.2/src/PaxHeaders.21352/modvars.f90 0000644 0000000 0000000 00000000130 13543334734 014617 x ustar 00 29 mtime=1569569244.26164218
30 atime=1569569240.382644657
29 ctime=1569569244.26164218
elk-6.3.2/src/modvars.f90 0000644 0025044 0025044 00000004537 13543334734 016701 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 modmain
use modmpi
contains
subroutine delvars
implicit none
if (.not.mp_mpi) return
! delete existing variables file
open(95,file='VARIABLES.OUT')
close(95,status='DELETE')
return
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')
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)
return
end subroutine
end module
elk-6.3.2/src/PaxHeaders.21352/modtddft.f90 0000644 0000000 0000000 00000000132 13543334734 014753 x ustar 00 30 mtime=1569569244.265642177
30 atime=1569569240.386644655
30 ctime=1569569244.265642177
elk-6.3.2/src/modtddft.f90 0000644 0025044 0025044 00000004242 13543334734 017024 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 and quadratic
! 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 A-field
real(8), allocatable :: afieldt(:,:)
! number of time steps after which observables are written to file
integer ntswrite
! the following variables are .true. if the corresponding quantities are to be
! written every ntswrite time steps
logical tdrho1d,tdrho2d,tdrho3d
logical tdmag2d,tdmag3d
logical tdcd2d,tdcd3d
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
end module
elk-6.3.2/src/PaxHeaders.21352/modgw.f90 0000644 0000000 0000000 00000000132 13543334734 014263 x ustar 00 30 mtime=1569569244.269642175
30 atime=1569569240.391644652
30 ctime=1569569244.269642175
elk-6.3.2/src/modgw.f90 0000644 0025044 0025044 00000002427 13543334734 016337 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-6.3.2/src/PaxHeaders.21352/modulr.f90 0000644 0000000 0000000 00000000132 13543334734 014450 x ustar 00 30 mtime=1569569244.273642172
30 atime=1569569240.395644649
30 ctime=1569569244.273642172
elk-6.3.2/src/modulr.f90 0000644 0025044 0025044 00000006062 13543334734 016523 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(:,:,:)
!---------------------------------------------------!
! 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 :: vsqmt(:,:,:),vsqir(:,:)
complex(8), allocatable :: 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-6.3.2/src/PaxHeaders.21352/modjx.f90 0000644 0000000 0000000 00000000130 13543334734 014265 x ustar 00 29 mtime=1569569244.27764217
30 atime=1569569240.400644646
29 ctime=1569569244.27764217
elk-6.3.2/src/modjx.f90 0000644 0025044 0025044 00000000613 13543334734 016336 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 A. Jakobsson.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modjx
! number of spin-spiral q-vectors for calculating the exchange coefficients
integer nqssjx
! range of cone angles for spin-spiral calculations
real(8) thssjx(2)
!**** add to manual, mention thssjx in degrees
end module
elk-6.3.2/src/PaxHeaders.21352/modomp.f90 0000644 0000000 0000000 00000000132 13543334734 014441 x ustar 00 30 mtime=1569569244.282642166
30 atime=1569569240.404644643
30 ctime=1569569244.282642166
elk-6.3.2/src/modomp.f90 0000644 0025044 0025044 00000006637 13543334734 016524 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 :: 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
logical function omp_get_nested()
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
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
if (maxthd.lt.0) then
! set the number of threads equal to the number of processors
maxthd=omp_get_num_procs()
call omp_set_num_threads(maxthd)
else if (maxthd.eq.0) then
! use the system default number of threads
maxthd=omp_get_max_threads()
else
! use the number of threads specified in the input file
call omp_set_num_threads(maxthd)
end if
if (maxthd1.le.0) then
maxthd1=maxthd
else
maxthd1=min(maxthd1,maxthd)
end if
! switch off dynamic allocation of threads
call omp_set_dynamic(.false.)
! allow nested parallelism
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
return
end subroutine
subroutine omp_reset
implicit none
! number of active threads at each nesting level
nathd(0)=1
nathd(1:)=0
return
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(holdthd_)
! 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(holdthd_)
return
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(freethd_)
! 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(freethd_)
return
end subroutine
end module
elk-6.3.2/src/PaxHeaders.21352/mkl_stub.f90 0000644 0000000 0000000 00000000132 13543334737 014771 x ustar 00 30 mtime=1569569247.248640272
30 atime=1569569240.408644641
30 ctime=1569569247.248640272
elk-6.3.2/src/mkl_stub.f90 0000644 0025044 0025044 00000000672 13543334737 017045 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
return
end subroutine
subroutine mkl_set_dynamic(dynamic)
implicit none
logical, intent(in) :: dynamic
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/mkl_init.f90 0000644 0000000 0000000 00000000132 13543334734 014754 x ustar 00 30 mtime=1569569244.290642161
30 atime=1569569240.413644638
30 ctime=1569569244.290642161
elk-6.3.2/src/mkl_init.f90 0000644 0025044 0025044 00000000756 13543334734 017033 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 number of MKL threads equal to one
call mkl_set_num_threads(1)
! set the maximum number of threads available to MKL
if (maxthdmkl.le.0) maxthdmkl=maxthd
! enable dynamic thread allocation
call mkl_set_dynamic(.true.)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/oblas_stub.f90 0000644 0000000 0000000 00000000132 13543334737 015306 x ustar 00 30 mtime=1569569247.252640269
30 atime=1569569240.417644635
30 ctime=1569569247.252640269
elk-6.3.2/src/oblas_stub.f90 0000644 0025044 0025044 00000000526 13543334737 017360 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
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/oblas_init.f90 0000644 0000000 0000000 00000000132 13543334734 015271 x ustar 00 30 mtime=1569569244.298642156
30 atime=1569569240.422644632
30 ctime=1569569244.298642156
elk-6.3.2/src/oblas_init.f90 0000644 0025044 0025044 00000000525 13543334734 017342 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)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/blis_stub.f90 0000644 0000000 0000000 00000000132 13543334737 015137 x ustar 00 30 mtime=1569569247.255640268
30 atime=1569569240.426644629
30 ctime=1569569247.255640268
elk-6.3.2/src/blis_stub.f90 0000644 0025044 0025044 00000000524 13543334737 017207 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
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/blis_init.f90 0000644 0000000 0000000 00000000132 13543334734 015122 x ustar 00 30 mtime=1569569244.306642151
30 atime=1569569240.431644626
30 ctime=1569569244.306642151
elk-6.3.2/src/blis_init.f90 0000644 0025044 0025044 00000000522 13543334734 017170 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)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/w90_stub.f90 0000644 0000000 0000000 00000000132 13543334737 014625 x ustar 00 30 mtime=1569569247.258640266
30 atime=1569569240.436644623
30 ctime=1569569247.258640266
elk-6.3.2/src/w90_stub.f90 0000644 0025044 0025044 00000003213 13543334737 016673 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(*,*)
stop
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/modw90.f90 0000644 0000000 0000000 00000000131 13543334734 014264 x ustar 00 30 mtime=1569569244.315642145
29 atime=1569569240.44064462
30 ctime=1569569244.315642145
elk-6.3.2/src/modw90.f90 0000644 0025044 0025044 00000002173 13543334734 016337 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
! 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-6.3.2/src/PaxHeaders.21352/zfftifc.f90 0000644 0000000 0000000 00000000132 13543334737 014604 x ustar 00 30 mtime=1569569247.296640241
30 atime=1569569240.445644617
30 ctime=1569569247.296640241
elk-6.3.2/src/zfftifc.f90 0000644 0025044 0025044 00000002401 13543334737 016650 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)
return
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 library required for real to complex &
&FFT")')
write(*,*)
stop
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/elk.f90 0000644 0000000 0000000 00000000132 13543334734 013721 x ustar 00 30 mtime=1569569244.330642136
30 atime=1569569240.449644615
30 ctime=1569569244.330642136
elk-6.3.2/src/elk.f90 0000644 0025044 0025044 00000241751 13543334734 016002 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
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 : ",I6)') np_mpi*maxthd
write(*,'("Maximum OpenMP nesting level : ",I4)') maxlvl
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
! 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,240,241,270,300,320,330,331,350,351,360,371,372, &
373,440,460,461,600,610,620,630,640,700,701])) 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(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(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)
!**************
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(360)
call ssfsmjx
case(371,372,373)
call curdenplot
case(400)
call writetmdu
case(430)
call writestrain
case(440)
call writestress
case(450)
call genafieldt
case(460,461)
call tddft
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 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 6.3.2}\\ \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 and Jagdish Kumar. 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, September 2019
! \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.52917721092(17) \AA, and the atomic unit of energy is the Hartree which
! equals 27.21138505(60) 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=x
! \end{verbatim}
! where x is the number of cores available on a particular node. In addition,
! some vendor-supplied BLAS/LAPACK libraries use OpenMP internally,
! for example MKL from Intel and ACML from AMD; refer to their documentation
! for usage.
! \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{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 4. 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/libxc\_funcs.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 anti-ferromagnetic 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.001$}
! 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 & 200}
! 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 for the OEP iterative solver & real & $0.01$}
! The optimised effective potential is determined using an interative method
! [Phys. Rev. Lett. 98, 196405 (2007)]. This variable sets the step length
! descibed in the article. See also {\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-6.3.2/src/PaxHeaders.21352/zbsht.f90 0000644 0000000 0000000 00000000132 13543334734 014300 x ustar 00 30 mtime=1569569244.334642133
30 atime=1569569240.461644607
30 ctime=1569569244.334642133
elk-6.3.2/src/zbsht.f90 0000644 0025044 0025044 00000002621 13543334734 016350 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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.
!BOP
! !ROUTINE: zbsht
! !INTERFACE:
subroutine zbsht(nr,nri,zfmt1,zfmt2)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! nr : number of radial mesh points (in,integer)
! nri : number of points on the inner part of the muffin-tin (in,integer)
! zfmt1 : input complex muffin-tin function in spherical harmonics
! (in,complex(*))
! zfmt2 : output complex muffin-tin function in spherical coordinates
! (out,complex(*))
! !DESCRIPTION:
! Performs a backward spherical harmonic transform (SHT) on a complex
! muffin-tin function expressed in spherical harmonics to obtain a function in
! spherical coordinates. See also {\tt genshtmat}.
!
! !REVISION HISTORY:
! Created October 2013 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nr,nri
complex(8), intent(in) :: zfmt1(*)
complex(8), intent(out) :: zfmt2(*)
! local variables
integer nro,i
! transform the inner part of the muffin-tin
call zgemm('N','N',lmmaxi,nri,lmmaxi,zone,zbshti,lmmaxi,zfmt1,lmmaxi,zzero, &
zfmt2,lmmaxi)
! transform the outer part of the muffin-tin
nro=nr-nri
i=lmmaxi*nri+1
call zgemm('N','N',lmmaxo,nro,lmmaxo,zone,zbshto,lmmaxo,zfmt1(i),lmmaxo,zzero, &
zfmt2(i),lmmaxo)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/zfsht.f90 0000644 0000000 0000000 00000000130 13543334734 014302 x ustar 00 29 mtime=1569569244.33964213
30 atime=1569569240.466644604
29 ctime=1569569244.33964213
elk-6.3.2/src/zfsht.f90 0000644 0025044 0025044 00000002617 13543334734 016361 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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.
!BOP
! !ROUTINE: zfsht
! !INTERFACE:
subroutine zfsht(nr,nri,zfmt1,zfmt2)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! nr : number of radial mesh points (in,integer)
! nri : number of points on the inner part of the muffin-tin (in,integer)
! zfmt1 : input complex muffin-tin function in spherical coordinates
! (in,complex(*))
! zfmt2 : output complex muffin-tin function in spherical harmonics
! (out,complex(*))
! !DESCRIPTION:
! Performs a forward spherical harmonic transform (SHT) on a complex
! muffin-tin function in spherical coordinates to obtain a function expressed
! in spherical harmonics. See also {\tt genshtmat}.
! !REVISION HISTORY:
! Created October 2013 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nr,nri
complex(8), intent(in) :: zfmt1(*)
complex(8), intent(out) :: zfmt2(*)
! local variables
integer nro,i
! transform the inner part of the muffin-tin
call zgemm('N','N',lmmaxi,nri,lmmaxi,zone,zfshti,lmmaxi,zfmt1,lmmaxi,zzero, &
zfmt2,lmmaxi)
! transform the outer part of the muffin-tin
nro=nr-nri
i=lmmaxi*nri+1
call zgemm('N','N',lmmaxo,nro,lmmaxo,zone,zfshto,lmmaxo,zfmt1(i),lmmaxo,zzero, &
zfmt2(i),lmmaxo)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rbsht.f90 0000644 0000000 0000000 00000000132 13543334734 014270 x ustar 00 30 mtime=1569569244.343642127
30 atime=1569569240.470644601
30 ctime=1569569244.343642127
elk-6.3.2/src/rbsht.f90 0000644 0025044 0025044 00000001322 13543334734 016335 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 rbsht(nr,nri,rfmt1,rfmt2)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: rfmt1(*)
real(8), intent(out) :: rfmt2(*)
! local variables
integer nro,i
! transform the inner part of the muffin-tin
call dgemm('N','N',lmmaxi,nri,lmmaxi,1.d0,rbshti,lmmaxi,rfmt1,lmmaxi,0.d0, &
rfmt2,lmmaxi)
! transform the outer part of the muffin-tin
nro=nr-nri
i=lmmaxi*nri+1
call dgemm('N','N',lmmaxo,nro,lmmaxo,1.d0,rbshto,lmmaxo,rfmt1(i),lmmaxo,0.d0, &
rfmt2(i),lmmaxo)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rfsht.f90 0000644 0000000 0000000 00000000132 13543334734 014274 x ustar 00 30 mtime=1569569244.347642125
30 atime=1569569240.474644599
30 ctime=1569569244.347642125
elk-6.3.2/src/rfsht.f90 0000644 0025044 0025044 00000001322 13543334734 016341 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 rfsht(nr,nri,rfmt1,rfmt2)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: rfmt1(*)
real(8), intent(out) :: rfmt2(*)
! local variables
integer nro,i
! transform the inner part of the muffin-tin
call dgemm('N','N',lmmaxi,nri,lmmaxi,1.d0,rfshti,lmmaxi,rfmt1,lmmaxi,0.d0, &
rfmt2,lmmaxi)
! transform the outer part of the muffin-tin
nro=nr-nri
i=lmmaxi*nri+1
call dgemm('N','N',lmmaxo,nro,lmmaxo,1.d0,rfshto,lmmaxo,rfmt1(i),lmmaxo,0.d0, &
rfmt2(i),lmmaxo)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/projsbf.f90 0000644 0000000 0000000 00000000132 13543334734 014613 x ustar 00 30 mtime=1569569244.352642122
30 atime=1569569240.479644595
30 ctime=1569569244.352642122
elk-6.3.2/src/projsbf.f90 0000644 0025044 0025044 00000003727 13543334734 016673 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 projsbf
use modmain
implicit none
! local variables
integer idm,is,ias,np
real(8) t1
! allocatable arrays
real(8), allocatable :: rfmt(:,:),rfir(:)
real(8), allocatable :: grfmt(:,:,:),grfir(:,:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:)
complex(8), allocatable :: zvclmt(:,:),zvclir(:)
allocate(rfmt(npmtmax,natmtot),rfir(ngtot))
allocate(grfmt(npmtmax,natmtot,3),grfir(ngtot,3))
allocate(zrhomt(npmtmax,natmtot),zrhoir(ngtot))
allocate(zvclmt(npmtmax,natmtot),zvclir(ngtot))
! compute the divergence of B_xc
rfmt(:,:)=0.d0
rfir(:)=0.d0
do idm=1,3
call gradrf(bxcmt(:,:,idm),bxcir(:,idm),grfmt,grfir)
do ias=1,natmtot
is=idxis(ias)
np=npmt(is)
rfmt(1:np,ias)=rfmt(1:np,ias)+grfmt(1:np,ias,idm)
end do
rfir(:)=rfir(:)+grfir(:,idm)
end do
! convert real muffin-tin divergence to complex spherical harmonic expansion
do ias=1,natmtot
is=idxis(ias)
call rtozfmt(nrmt(is),nrmti(is),rfmt(:,ias),zrhomt(:,ias))
end do
! store real interstitial divergence in a complex array
zrhoir(:)=rfir(:)
! solve the complex Poisson's equation
call genzvclmt(nrmt,nrmti,nrmtmax,rlmt,wprmt,npmtmax,zrhomt,zvclmt)
call zpotcoul(nrmt,nrmti,npmt,npmti,nrmtmax,rlmt,ngridg,igfft,ngvec,gc,gclg, &
ngvec,jlgrmt,ylmg,sfacg,zrhoir,npmtmax,zvclmt,zvclir)
! convert complex muffin-tin potential to real spherical harmonic expansion
do ias=1,natmtot
is=idxis(ias)
call ztorfmt(nrmt(is),nrmti(is),zvclmt(:,ias),rfmt(:,ias))
end do
! store complex interstitial potential in real array
rfir(:)=dble(zvclir(:))
! compute the gradient
call gradrf(rfmt,rfir,grfmt,grfir)
! add gradient over 4*pi to existing B_xc
t1=1.d0/fourpi
bxcmt(:,:,:)=bxcmt(:,:,:)+t1*grfmt(:,:,:)
bxcir(:,:)=bxcir(:,:)+t1*grfir(:,:)
deallocate(rfmt,rfir,grfmt,grfir)
deallocate(zrhomt,zrhoir,zvclmt,zvclir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/fsmooth.f90 0000644 0000000 0000000 00000000132 13543334734 014625 x ustar 00 30 mtime=1569569244.356642119
30 atime=1569569240.483644593
30 ctime=1569569244.356642119
elk-6.3.2/src/fsmooth.f90 0000644 0025044 0025044 00000001652 13543334734 016700 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2005 J. K. Dewhurst and S. Sharma.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: fsmooth
! !INTERFACE:
pure subroutine fsmooth(m,n,f)
! !INPUT/OUTPUT PARAMETERS:
! m : number of 3-point running averages to perform (in,integer)
! n : number of point (in,integer)
! f : function array (inout,real(n))
! !DESCRIPTION:
! Removes numerical noise from a function by performing $m$ successive
! 3-point running averages on the data. The endpoints are kept fixed.
!
! !REVISION HISTORY:
! Created December 2005 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: m,n
real(8), intent(inout) :: f(n)
! local variables
integer i,j
! automatic arrays
real(8) g(n)
do i=1,m
do j=2,n-1
g(j)=0.3333333333333333333d0*(f(j-1)+f(j)+f(j+1))
end do
f(2:n-1)=g(2:n-1)
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/nfftifc.f90 0000644 0000000 0000000 00000000131 13543334734 014564 x ustar 00 30 mtime=1569569244.360642117
29 atime=1569569240.48764459
30 ctime=1569569244.360642117
elk-6.3.2/src/nfftifc.f90 0000644 0025044 0025044 00000002062 13543334734 016634 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: nfftifc
! !INTERFACE:
subroutine nfftifc(n)
! !INPUT/OUTPUT PARAMETERS:
! n : required/avalable grid size (inout,integer)
! !DESCRIPTION:
! Interface to the grid requirements of the fast Fourier transform routine.
! Most routines restrict $n$ to specific prime factorisations. This routine
! returns the next largest grid size allowed by the FFT routine.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(inout) :: n
! local variables
integer i,j
! currently we use primes 2, 3 and 5
integer, parameter :: np=3
integer p(np)
data p / 2,3,5 /
if (n.le.0) then
write(*,*)
write(*,'("Error(nfftifc): n <= 0 : ",I8)') n
write(*,*)
stop
end if
10 continue
i=n
do j=1,np
do while(mod(i,p(j)).eq.0)
i=i/p(j)
end do
end do
if (i.ne.1) then
n=n+1
goto 10
end if
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rfinp.f90 0000644 0000000 0000000 00000000132 13543334734 014264 x ustar 00 30 mtime=1569569244.365642113
30 atime=1569569240.491644588
30 ctime=1569569244.365642113
elk-6.3.2/src/rfinp.f90 0000644 0025044 0025044 00000003565 13543334734 016344 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: rfinp
! !INTERFACE:
real(8) function rfinp(rfmt1,rfir1,rfmt2,rfir2)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! rfmt1 : first function in real spherical harmonics for all muffin-tins
! (in,real(npmtmax,natmtot))
! rfir1 : first real interstitial function in real-space (in,real(ngtot))
! rfmt2 : second function in real spherical harmonics for all muffin-tins
! (in,real(npmtmax,natmtot))
! rfir2 : second real interstitial function in real-space (in,real(ngtot))
! !DESCRIPTION:
! Calculates the inner product of two real functions over the entire unit
! cell. The input muffin-tin functions should have angular momentum cut-off
! {\tt lmaxo}. In the interstitial region, the integrand is multiplied with
! the characteristic function, $\tilde{\Theta}({\bf r})$, to remove the
! contribution from the muffin-tin. See routines {\tt rfmtinp} and
! {\tt gencfun}.
!
! !REVISION HISTORY:
! Created July 2004 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rfmt1(npmtmax,natmtot),rfir1(ngtot)
real(8), intent(in) :: rfmt2(npmtmax,natmtot),rfir2(ngtot)
! local variables
integer is,ias,ir,nthd
! external functions
real(8) rfmtinp
external rfmtinp
! interstitial contribution
rfinp=0.d0
do ir=1,ngtot
rfinp=rfinp+rfir1(ir)*rfir2(ir)*cfunir(ir)
end do
rfinp=rfinp*omega/dble(ngtot)
! muffin-tin contribution
call holdthd(natmtot,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(is) REDUCTION(+:rfinp) &
!$OMP NUM_THREADS(nthd)
do ias=1,natmtot
is=idxis(ias)
rfinp=rfinp+rfmtinp(nrmt(is),nrmti(is),wrmt(:,is),rfmt1(:,ias),rfmt2(:,ias))
end do
!$OMP END PARALLEL DO
call freethd(nthd)
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/splint.f90 0000644 0000000 0000000 00000000132 13543334734 014457 x ustar 00 30 mtime=1569569244.369642111
30 atime=1569569240.496644585
30 ctime=1569569244.369642111
elk-6.3.2/src/splint.f90 0000644 0025044 0025044 00000003417 13543334734 016533 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.
real(8) function splint(n,x,f)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: x(n),f(n)
! local variables
integer i
real(8) x0,x1,x2,x3,y0,y1,y2,y3
real(8) t0,t1,t2,t3,t4,t5,t6,t7
! external functions
real(8) polynm
external polynm
if (n.le.4) then
splint=polynm(-1,n,x,f,x(n))
return
end if
! fit piecewise cubic spline to data and integrate
x0=x(1)
x1=x(2)-x0; x2=x(3)-x0; x3=x(4)-x0
t4=x1-x2; t5=x1-x3; t6=x2-x3
y0=f(1)
y1=f(2)-y0; y2=f(3)-y0; y3=f(4)-y0
t1=x1*x2*y3; t2=x2*x3*y1; t3=x1*x3
t0=0.5d0/(t3*t4*t5*t6)
t3=t3*y2
t7=t1*t4+t2*t6-t3*t5
t4=x1**2; t5=x2**2; t6=x3**2
y1=t3*t6-t1*t5; y3=t2*t5-t3*t4; y2=t1*t4-t2*t6
t1=x1*y1+x2*y2+x3*y3
t2=y1+y2+y3
splint=x2*(y0+t0*(t1+x2*(0.5d0*t7*x2-0.6666666666666666667d0*t2)))
do i=3,n-3
x0=x(i)
x1=x(i-1)-x0; x2=x(i+1)-x0; x3=x(i+2)-x0
t4=x1-x2; t5=x1-x3; t6=x2-x3; t3=x1*x3
y0=f(i)
y1=f(i-1)-y0; y2=f(i+1)-y0; y3=f(i+2)-y0
t1=x1*x2*y3; t2=x2*x3*y1
t0=0.5d0/(t3*t4*t5*t6)
t3=t3*y2
t7=t1*t4+t2*t6-t3*t5
t4=x1**2; t5=x2**2; t6=x3**2
y1=t3*t6-t1*t5; y2=t1*t4-t2*t6; y3=t2*t5-t3*t4
t1=x1*y1+x2*y2+x3*y3
t2=y1+y2+y3
splint=splint+x2*(y0+t0*(t1+x2*(0.5d0*t7*x2-0.6666666666666666667d0*t2)))
end do
x0=x(n-2)
x1=x(n-3)-x0; x2=x(n-1)-x0; x3=x(n)-x0
t4=x1-x2; t5=x1-x3; t6=x2-x3
y0=f(n-2)
y1=f(n-3)-y0; y2=f(n-1)-y0; y3=f(n)-y0
t1=x1*x2; t2=x2*x3*y1; t3=x1*x3*y2
t0=0.5d0/(t1*t4*t5*t6)
t1=t1*y3
t7=t1*t4+t2*t6-t3*t5
t4=x1**2; t5=x2**2; t6=x3**2
y1=t3*t6-t1*t5; y2=t1*t4-t2*t6; y3=t2*t5-t3*t4
t1=x1*y1+x2*y2+x3*y3
t2=y1+y2+y3
splint=splint+x3*(y0+t0*(t1+x3*(0.5d0*t7*x3-0.6666666666666666667d0*t2)))
return
end function
elk-6.3.2/src/PaxHeaders.21352/spline.f90 0000644 0000000 0000000 00000000132 13543334734 014440 x ustar 00 30 mtime=1569569244.373642108
30 atime=1569569240.500644582
30 ctime=1569569244.373642108
elk-6.3.2/src/spline.f90 0000644 0025044 0025044 00000005655 13543334734 016522 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 Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: spline
! !INTERFACE:
subroutine spline(n,x,f,cf)
! !INPUT/OUTPUT PARAMETERS:
! n : number of points (in,integer)
! x : abscissa array (in,real(n))
! f : input data array (in,real(n))
! cf : cubic spline coefficients (out,real(3,n))
! !DESCRIPTION:
! Calculates the coefficients of a cubic spline fitted to input data. In other
! words, given a set of data points $f_i$ defined at $x_i$, where
! $i=1\ldots n$, the coefficients $c_j^i$ are determined such that
! $$ y_i(x)=f_i+c_1^i(x-x_i)+c_2^i(x-x_i)^2+c_3^i(x-x_i)^3, $$
! is the interpolating function for $x\in[x_i,x_{i+1})$. The coefficients are
! determined piecewise by fitting a cubic polynomial to adjacent points.
!
! !REVISION HISTORY:
! Created November 2011 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: x(n),f(n)
real(8), intent(out) :: cf(3,n)
! local variables
integer i
real(8) x0,x1,x2,x3,y0,y1,y2,y3
real(8) t0,t1,t2,t3,t4,t5,t6,t7
if (n.le.0) then
write(*,*)
write(*,'("Error(spline): n <= 0 : ",I8)') n
write(*,*)
stop
end if
if (n.eq.1) then
cf(:,1)=0.d0
return
end if
if (n.eq.2) then
cf(1,1)=(f(2)-f(1))/(x(2)-x(1))
cf(2:3,1)=0.d0
cf(1,2)=cf(1,1)
cf(2:3,2)=0.d0
return
end if
if (n.eq.3) then
x0=x(1)
x1=x(2)-x0; x2=x(3)-x0
y0=f(1)
y1=f(2)-y0; y2=f(3)-y0
t0=1.d0/(x1*x2*(x2-x1))
t3=x1*y2; t4=x2*y1
t1=t0*(x2*t4-x1*t3)
t2=t0*(t3-t4)
cf(1,1)=t1
cf(2,1)=t2
cf(3,1)=0.d0
t3=2.d0*t2
cf(1,2)=t1+t3*x1
cf(2,2)=t2
cf(3,2)=0.d0
cf(1,3)=t1+t3*x2
cf(2,3)=t2
cf(3,3)=0.d0
return
end if
x0=x(1)
x1=x(2)-x0; x2=x(3)-x0; x3=x(4)-x0
t4=x1-x2; t5=x1-x3; t6=x2-x3
y0=f(1)
y1=f(2)-y0; y2=f(3)-y0; y3=f(4)-y0
t1=x1*x2*y3; t2=x2*x3*y1; t3=x1*x3
t0=1.d0/(x2*t3*t4*t5*t6)
t3=t3*y2
t7=t0*(t1*t4+t2*t6-t3*t5)
t4=x1**2; t5=x2**2; t6=x3**2
y1=t3*t6-t1*t5; y3=t2*t5-t3*t4; y2=t1*t4-t2*t6
t1=t0*(x1*y1+x2*y2+x3*y3)
t2=-t0*(y1+y2+y3)
cf(1,1)=t1; cf(2,1)=t2; cf(3,1)=t7
cf(1,2)=t1+2.d0*t2*x1+3.d0*t7*t4
cf(2,2)=t2+3.d0*t7*x1
cf(3,2)=t7
if (n.eq.4) then
cf(1,3)=t1+2.d0*t2*x2+3.d0*t7*t5
cf(2,3)=t2+3.d0*t7*x2
cf(3,3)=t7
cf(1,4)=t1+2.d0*t2*x3+3.d0*t7*t6
cf(2,4)=t2+3.d0*t7*x3
cf(3,4)=t7
return
end if
do i=3,n-2
x0=x(i)
x1=x(i-1)-x0; x2=x(i+1)-x0; x3=x(i+2)-x0
t4=x1-x2; t5=x1-x3; t6=x2-x3
y0=f(i)
y1=f(i-1)-y0; y2=f(i+1)-y0; y3=f(i+2)-y0
t1=x1*x2*y3; t2=x2*x3*y1; t3=x1*x3
t0=1.d0/(x2*t3*t4*t5*t6)
t3=t3*y2
t7=t0*(t1*t4+t2*t6-t3*t5)
t4=x1**2; t5=x2**2; t6=x3**2
y1=t3*t6-t1*t5; y2=t1*t4-t2*t6; y3=t2*t5-t3*t4
t1=t0*(x1*y1+x2*y2+x3*y3)
t2=-t0*(y1+y2+y3)
cf(1,i)=t1; cf(2,i)=t2; cf(3,i)=t7
end do
cf(1,n-1)=t1+2.d0*t2*x2+3.d0*t7*t5
cf(2,n-1)=t2+3.d0*t7*x2
cf(3,n-1)=t7
cf(1,n)=t1+2.d0*t2*x3+3.d0*t7*t6
cf(2,n)=t2+3.d0*t7*x3
cf(3,n)=t7
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/wsplint.f90 0000644 0000000 0000000 00000000132 13543334734 014646 x ustar 00 30 mtime=1569569244.377642106
30 atime=1569569240.505644579
30 ctime=1569569244.377642106
elk-6.3.2/src/wsplint.f90 0000644 0025044 0025044 00000001371 13543334734 016717 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 wsplint(n,x,w)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: x(n)
real(8), intent(out) :: w(n)
! local variables
integer i
! automatic arrays
real(8) f(9)
! external functions
real(8) splint
external splint
if (n.le.9) then
do i=1,n
f(:)=0.d0
f(i)=1.d0
w(i)=splint(n,x,f)
end do
return
end if
do i=1,4
f(:)=0.d0
f(i)=1.d0
w(i)=splint(9,x,f)
end do
f(:)=0.d0
f(5)=1.d0
do i=5,n-4
w(i)=splint(9,x(i-4),f)
end do
do i=1,4
f(:)=0.d0
f(i+5)=1.d0
w(n-4+i)=splint(9,x(n-8),f)
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/wsplintp.f90 0000644 0000000 0000000 00000000132 13543334734 015026 x ustar 00 30 mtime=1569569244.383642102
30 atime=1569569240.509644576
30 ctime=1569569244.383642102
elk-6.3.2/src/wsplintp.f90 0000644 0025044 0025044 00000003055 13543334734 017100 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 wsplintp(n,x,w)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: x(n)
real(8), intent(out) :: w(4,n)
! local variables
integer i
real(8) f(4),t1,t2
! external functions
real(8) polynm
external polynm
if (n.lt.4) then
write(*,*)
write(*,'("Error(wsplintp): n < 4 : ",I8)') n
write(*,*)
stop
end if
w(:,1)=0.d0
f(:)=0.d0
f(1)=1.d0
w(1,2)=polynm(-1,4,x,f,x(2))
f(1)=0.d0
f(2)=1.d0
w(2,2)=polynm(-1,4,x,f,x(2))
f(2)=0.d0
f(3)=1.d0
w(3,2)=polynm(-1,4,x,f,x(2))
f(3)=0.d0
f(4)=1.d0
w(4,2)=polynm(-1,4,x,f,x(2))
do i=3,n-1
f(:)=0.d0
f(1)=1.d0
t1=polynm(-1,4,x(i-2),f,x(i-1))
t2=polynm(-1,4,x(i-2),f,x(i))
w(1,i)=t2-t1
f(1)=0.d0
f(2)=1.d0
t1=polynm(-1,4,x(i-2),f,x(i-1))
t2=polynm(-1,4,x(i-2),f,x(i))
w(2,i)=t2-t1
f(2)=0.d0
f(3)=1.d0
t1=polynm(-1,4,x(i-2),f,x(i-1))
t2=polynm(-1,4,x(i-2),f,x(i))
w(3,i)=t2-t1
f(3)=0.d0
f(4)=1.d0
t1=polynm(-1,4,x(i-2),f,x(i-1))
t2=polynm(-1,4,x(i-2),f,x(i))
w(4,i)=t2-t1
end do
f(:)=0.d0
f(1)=1.d0
t1=polynm(-1,4,x(n-3),f,x(n-1))
t2=polynm(-1,4,x(n-3),f,x(n))
w(1,n)=t2-t1
f(1)=0.d0
f(2)=1.d0
t1=polynm(-1,4,x(n-3),f,x(n-1))
t2=polynm(-1,4,x(n-3),f,x(n))
w(2,n)=t2-t1
f(2)=0.d0
f(3)=1.d0
t1=polynm(-1,4,x(n-3),f,x(n-1))
t2=polynm(-1,4,x(n-3),f,x(n))
w(3,n)=t2-t1
f(3)=0.d0
f(4)=1.d0
t1=polynm(-1,4,x(n-3),f,x(n-1))
t2=polynm(-1,4,x(n-3),f,x(n))
w(4,n)=t2-t1
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/splintwp.f90 0000644 0000000 0000000 00000000132 13543334734 015026 x ustar 00 30 mtime=1569569244.387642099
30 atime=1569569240.514644573
30 ctime=1569569244.387642099
elk-6.3.2/src/splintwp.f90 0000644 0025044 0025044 00000001154 13543334734 017076 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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.
pure subroutine splintwp(n,wp,f,g)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: wp(4,n),f(n)
real(8), intent(out) :: g(n)
! local variables
integer i
g(1)=0.d0
g(2)=wp(1,2)*f(1)+wp(2,2)*f(2)+wp(3,2)*f(3)+wp(4,2)*f(4)
do i=3,n-1
g(i)=g(i-1)+wp(1,i)*f(i-2)+wp(2,i)*f(i-1)+wp(3,i)*f(i)+wp(4,i)*f(i+1)
end do
g(n)=g(n-1)+wp(1,n)*f(n-3)+wp(2,n)*f(n-2)+wp(3,n)*f(n-1)+wp(4,n)*f(n)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/sphcover.f90 0000644 0000000 0000000 00000000131 13543334734 014776 x ustar 00 30 mtime=1569569244.390642097
29 atime=1569569240.51964457
30 ctime=1569569244.390642097
elk-6.3.2/src/sphcover.f90 0000644 0025044 0025044 00000002555 13543334734 017055 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 Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: sphcover
! !INTERFACE:
subroutine sphcover(n,tp)
! !INPUT/OUTPUT PARAMETERS:
! n : number of required points (in,integer)
! tp : (theta, phi) coordinates (out,real(2,n))
! !DESCRIPTION:
! Produces a set of $N$ points which cover the unit sphere nearly optimally.
! The points in spherical $(\theta,\phi)$ coordinates are generated using the
! explicit `golden section' formula:
! \begin{align*}
! \theta_k&=\arccos\left[1-\left(k-\tfrac{1}{2}\right)\delta z\right] \\
! \phi_k&=(k-1)\delta\phi,
! \end{align*}
! where $\delta z=2/n$ and $\delta\phi=\pi(1-\sqrt{5})$.
!
! !REVISION HISTORY:
! Created April 2008 (JKD)
! Improved covering, October 2009 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(out) :: tp(2,n)
! local variables
integer k
real(8), parameter :: pi=3.1415926535897932385d0
real(8) z,dz,p,dp
if (n.le.0) then
write(*,*)
write(*,'("Error(sphcover): n <= 0 : ",I8)') n
write(*,*)
stop
end if
dz=2.d0/dble(n)
z=1.d0-dz/2.d0
tp(1,1)=acos(z)
dp=pi*(1.d0-sqrt(5.d0))
p=0.d0
tp(2,1)=p
do k=2,n
z=z-dz
tp(1,k)=acos(z)
p=p+dp
tp(2,k)=mod(p,2.d0*pi)
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/r3frac.f90 0000644 0000000 0000000 00000000132 13543334734 014326 x ustar 00 30 mtime=1569569244.394642095
30 atime=1569569240.523644567
30 ctime=1569569244.394642095
elk-6.3.2/src/r3frac.f90 0000644 0025044 0025044 00000002245 13543334734 016400 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:
pure 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)
v(1)=v(1)-int(v(1))
if (v(1).lt.0.d0) v(1)=v(1)+1.d0
if ((1.d0-v(1)).lt.eps) v(1)=0.d0
if (v(1).lt.eps) v(1)=0.d0
v(2)=v(2)-int(v(2))
if (v(2).lt.0.d0) v(2)=v(2)+1.d0
if ((1.d0-v(2)).lt.eps) v(2)=0.d0
if (v(2).lt.eps) v(2)=0.d0
v(3)=v(3)-int(v(3))
if (v(3).lt.0.d0) v(3)=v(3)+1.d0
if ((1.d0-v(3)).lt.eps) v(3)=0.d0
if (v(3).lt.eps) v(3)=0.d0
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/genvsig.f90 0000644 0000000 0000000 00000000132 13543334734 014610 x ustar 00 30 mtime=1569569244.399642092
30 atime=1569569240.527644565
30 ctime=1569569244.399642092
elk-6.3.2/src/genvsig.f90 0000644 0025044 0025044 00000001654 13543334734 016665 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: genvsig
! !INTERFACE:
subroutine genvsig
! !USES:
use modmain
! !DESCRIPTION:
! Generates the Fourier transform of the Kohn-Sham effective potential in the
! interstitial region. The potential is first multiplied by the characteristic
! function which zeros it in the muffin-tins. See routine {\tt gencfun}.
!
! !REVISION HISTORY:
! Created January 2004 (JKD)
!EOP
!BOC
implicit none
! allocatable arrays
complex(8), allocatable :: zfft(:)
allocate(zfft(ngtot))
! multiply potential by characteristic function in real-space
zfft(:)=vsir(:)*cfunir(:)
! Fourier transform to G-space
call zfftifc(3,ngridg,-1,zfft)
! store in global array
vsig(1:ngvec)=zfft(igfft(1:ngvec))
deallocate(zfft)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/gencfun.f90 0000644 0000000 0000000 00000000132 13543334734 014573 x ustar 00 30 mtime=1569569244.403642089
30 atime=1569569240.532644562
30 ctime=1569569244.403642089
elk-6.3.2/src/gencfun.f90 0000644 0025044 0025044 00000004037 13543334734 016646 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: gencfun
! !INTERFACE:
subroutine gencfun
! !USES:
use modmain
! !DESCRIPTION:
! Generates the smooth characteristic function. This is the function which is
! 0 within the muffin-tins and 1 in the intersitial region and is constructed
! from radial step function form factors with $GG_{\rm max}\end{cases} $$
! where $R_i$ is the muffin-tin radius of the $i$th species and $\Omega$ is
! the unit cell volume. Therefore the characteristic function in $G$-space is
! $$ \tilde{\Theta}({\bf G})=\delta_{G,0}-\sum_{ij}\exp(-i{\bf G}\cdot
! {\bf r}_{ij})\tilde{\Theta}_i(G), $$
! where ${\bf r}_{ij}$ is the position of the $j$th atom of the $i$th species.
!
! !REVISION HISTORY:
! Created January 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ia,ig
real(8) v1,v2,v3,t1
complex(8) z1
! allocatable arrays
complex(8), allocatable :: zfft(:)
! allocate global characteristic function arrays
if (allocated(cfunig)) deallocate(cfunig)
allocate(cfunig(ngtot))
if (allocated(cfunir)) deallocate(cfunir)
allocate(cfunir(ngtot))
cfunig(1)=1.d0
cfunig(2:)=0.d0
! begin loop over species
do is=1,nspecies
! loop over atoms
do ia=1,natoms(is)
v1=atposc(1,ia,is); v2=atposc(2,ia,is); v3=atposc(3,ia,is)
do ig=1,ngtot
! structure factor
t1=vgc(1,ig)*v1+vgc(2,ig)*v2+vgc(3,ig)*v3
z1=cmplx(cos(t1),-sin(t1),8)
! add to characteristic function in G-space
cfunig(ig)=cfunig(ig)-ffacg(ig,is)*z1
end do
end do
end do
allocate(zfft(ngtot))
zfft(igfft(:))=cfunig(:)
! Fourier transform to real-space
call zfftifc(3,ngridg,1,zfft)
cfunir(:)=dble(zfft(:))
deallocate(zfft)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/zfpack.f90 0000644 0000000 0000000 00000000132 13543334734 014424 x ustar 00 30 mtime=1569569244.407642087
30 atime=1569569240.536644559
30 ctime=1569569244.407642087
elk-6.3.2/src/zfpack.f90 0000644 0025044 0025044 00000001650 13543334734 016475 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.
subroutine zfpack(tpack,n,np,ld,zfmt,zfir,v)
use modmain
implicit none
! arguments
logical, intent(in) :: tpack
integer, intent(inout) :: n
integer, intent(in) :: np(nspecies)
integer, intent(in) :: ld
complex(8), intent(inout) :: zfmt(ld,natmtot),zfir(ngtot)
real(8), intent(out) :: v(*)
! local variables
integer is,ias,k
if (tpack) then
! pack the function
do ias=1,natmtot
is=idxis(ias)
k=2*np(is)
call dcopy(k,zfmt(:,ias),1,v(n+1),1)
n=n+k
end do
k=2*ngtot
call dcopy(k,zfir,1,v(n+1),1)
n=n+k
else
! unpack the function
do ias=1,natmtot
is=idxis(ias)
k=2*np(is)
call dcopy(k,v(n+1),1,zfmt(:,ias),1)
n=n+k
end do
k=2*ngtot
call dcopy(k,v(n+1),1,zfir,1)
n=n+k
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/addlorbcnd.f90 0000644 0000000 0000000 00000000132 13543334734 015242 x ustar 00 30 mtime=1569569244.411642084
30 atime=1569569240.541644556
30 ctime=1569569244.411642084
elk-6.3.2/src/addlorbcnd.f90 0000644 0025044 0025044 00000001601 13543334734 017307 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.
subroutine addlorbcnd
use modmain
implicit none
! local variables
integer is,nlo,l,io
if (.not.lorbcnd) return
! add conduction local-orbitals to each species
do is=1,nspecies
nlo=nlorb(is)
do l=0,lmaxo
nlo=nlo+1
if (nlo.gt.maxlorb) then
write(*,*)
write(*,'("Error(addlorbcnd): nlorb too large : ",I8)') nlo
write(*,'(" for species ",I4)') is
write(*,'("Adjust maxlorb in modmain and recompile code")')
write(*,*)
stop
end if
lorbl(nlo,is)=l
lorbord(nlo,is)=lorbordc
do io=1,lorbordc
lorbe0(io,nlo,is)=0.15d0
lorbdm(io,nlo,is)=io-1
lorbve(io,nlo,is)=.true.
end do
end do
nlorb(is)=nlo
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rfint.f90 0000644 0000000 0000000 00000000132 13543334734 014270 x ustar 00 30 mtime=1569569244.416642081
30 atime=1569569240.545644553
30 ctime=1569569244.416642081
elk-6.3.2/src/rfint.f90 0000644 0025044 0025044 00000001440 13543334734 016336 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.
real(8) function rfint(rfmt,rfir)
use modmain
implicit none
! arguments
real(8), intent(in) :: rfmt(npmtmax,natmtot),rfir(ngtot)
! local variables
integer is,ias,nr,nri
real(8) t1
! automatic arrays
real(8) fr(nrmtmax)
! interstitial contribution
rfint=dot_product(rfir(:),cfunir(:))
rfint=rfint*omega/dble(ngtot)
! muffin-tin contribution
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
! extract the l=m=0 component
call rfmtlm(1,nr,nri,rfmt(:,ias),fr)
! integrate to the muffin-tin radius
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
rfint=rfint+fourpi*y00*t1
end do
return
end function
elk-6.3.2/src/PaxHeaders.21352/sortidx.f90 0000644 0000000 0000000 00000000132 13543334734 014642 x ustar 00 30 mtime=1569569244.420642078
30 atime=1569569240.549644551
30 ctime=1569569244.420642078
elk-6.3.2/src/sortidx.f90 0000644 0025044 0025044 00000003027 13543334734 016713 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: sortidx
! !INTERFACE:
subroutine sortidx(n,x,idx)
! !INPUT/OUTPUT PARAMETERS:
! n : number of elements in array (in,integer)
! x : real array (in,real(n))
! idx : permutation index (out,integer(n))
! !DESCRIPTION:
! Finds the permutation index {\tt idx} which sorts the real array {\tt x}
! into ascending order. No sorting of the array {\tt x} itself is performed.
! Uses the heapsort algorthim.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
! Included tolerance eps, April 2006 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: x(n)
integer, intent(out) :: idx(n)
! local variables
integer i,j,k,l,m
! tolerance for deciding if one number is smaller than another
real(8), parameter :: eps=1.d-14
if (n.le.0) then
write(*,*)
write(*,'("Error(sortidx): n <= 0 : ",I8)') n
write(*,*)
stop
end if
do i=1,n
idx(i)=i
end do
if (n.eq.1) return
l=n/2+1
k=n
10 continue
if (l.gt.1) then
l=l-1
m=idx(l)
else
m=idx(k)
idx(k)=idx(1)
k=k-1
if (k.eq.1) then
idx(1)=m
return
end if
end if
i=l
j=l+l
20 continue
if (j.le.k) then
if (j.lt.k) then
if (x(idx(j)).lt.x(idx(j+1))+eps) j=j+1
end if
if (x(m).lt.x(idx(j))+eps) then
idx(i)=idx(j)
i=j
j=j+j
else
j=k+1
end if
goto 20
end if
idx(i)=m
goto 10
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/gengkvec.f90 0000644 0000000 0000000 00000000132 13543334734 014737 x ustar 00 30 mtime=1569569244.424642076
30 atime=1569569240.554644548
30 ctime=1569569244.424642076
elk-6.3.2/src/gengkvec.f90 0000644 0025044 0025044 00000004256 13543334734 017015 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2012 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: gengkvec
! !INTERFACE:
subroutine gengkvec(ngvec,ivg,vgc,vkl,vkc,gkmax,ngkmax,ngk,igkig,vgkl,vgkc,gkc)
! !INPUT/OUTPUT PARAMETERS:
! ngvec : number of G-vectors (in,integer)
! ivg : G-vector integer coordinates (in,integer(3,ngvec))
! vgc : G-vectors in Cartesian coordinates (in,real(3,ngvec))
! vkl : k-point vector in lattice coordinates (in,real(3))
! vkc : k-point vector in Cartesian coordinates (in,real(3))
! gkmax : G+k-vector cut-off (in,real)
! ngkmax : maximum number of G+k-vectors (in,integer)
! ngk : number of G+k-vectors returned (out,integer)
! igkig : index from G+k-vectors to G-vectors (out,integer(ngkmax))
! vgkl : G+k-vectors in lattice coordinates (out,real(3,ngkmax))
! vgkc : G+k-vectors in Cartesian coordinates (out,real(3,ngkmax))
! gkc : length of G+k-vectors (out,real(ngkmax))
! !DESCRIPTION:
! Generates a set of ${\bf G+k}$-vectors for the input $k$-point with length
! less than {\tt gkmax}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
! Removed spherical coordinate generation, May 2010 (JKD)
! Removed modmain and added arguments, September 2012 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ngvec,ivg(3,ngvec)
real(8), intent(in) :: vgc(3,ngvec)
real(8), intent(in) :: vkl(3),vkc(3)
real(8), intent(in) :: gkmax
integer, intent(in) :: ngkmax
integer, intent(out) :: ngk,igkig(ngkmax)
real(8), intent(out) :: vgkl(3,ngkmax),vgkc(3,ngkmax),gkc(ngkmax)
! local variables
integer ig
real(8) v1,v2,v3,t0,t1
t0=gkmax**2
ngk=0
do ig=1,ngvec
v1=vgc(1,ig)+vkc(1)
v2=vgc(2,ig)+vkc(2)
v3=vgc(3,ig)+vkc(3)
t1=v1**2+v2**2+v3**2
if (t1.lt.t0) then
ngk=ngk+1
! index to G-vector
igkig(ngk)=ig
! G+k-vector in lattice coordinates
vgkl(:,ngk)=dble(ivg(:,ig))+vkl(:)
! G+k-vector in Cartesian coordinates
vgkc(1,ngk)=v1
vgkc(2,ngk)=v2
vgkc(3,ngk)=v3
! length of G+k-vector
gkc(ngk)=sqrt(t1)
if (ngk.eq.ngkmax) exit
end if
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/pade.f90 0000644 0000000 0000000 00000000132 13543334734 014057 x ustar 00 30 mtime=1569569244.428642073
30 atime=1569569240.558644545
30 ctime=1569569244.428642073
elk-6.3.2/src/pade.f90 0000644 0025044 0025044 00000004657 13543334734 016142 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) A. Sanna 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.
!BOP
! !ROUTINE: pade
! !INTERFACE:
subroutine pade(ni,zi,ui,no,zo,uo)
! !INPUT/OUTPUT PARAMETERS:
! ni : number of input points (in,integer)
! zi : input points (in,complex(ni))
! ui : input function values (in,complex(ni))
! no : number of output points (in,integer)
! zo : output points (in,complex(no))
! uo : output function values (out,complex(no))
! !DESCRIPTION:
! Calculates a Pad\'{e} approximant of a function, given the function
! evaluated on a set of points in the complex plane. The function is returned
! for a set of complex output points. The algorithm from H. J. Vidberg and
! J. W. Serene {\it J. Low Temp. Phys.} {\bf 29}, 179 (1977) is used.
!
! !REVISION HISTORY:
! Created December 2010 (Antonio Sanna)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ni
complex(8), intent(in) :: zi(ni)
complex(8), intent(in) :: ui(ni)
integer, intent(in) :: no
complex(8), intent(in) :: zo(no)
complex(8), intent(out) :: uo(no)
! local variables
integer i,j
real(8) t1
complex(8) a0,a1,b0,b1,z1,z2
! allocatable arrays
complex(8), allocatable :: g(:,:)
if ((ni.le.0).or.(no.le.0)) then
write(*,*)
write(*,'("Error(pade): invalid number of input or output points : ",2I8)') &
ni,no
write(*,*)
stop
end if
allocate(g(ni,ni))
! define the g functions using Eq. (A2)
g(1,:)=ui(:)
do i=2,ni
do j=i,ni
z1=(zi(j)-zi(i-1))*g(i-1,j)
t1=abs(dble(z1))+abs(aimag(z1))
if (t1.gt.1.d-14) then
g(i,j)=(g(i-1,i-1)-g(i-1,j))/z1
else
g(i,j)=0.d0
end if
end do
end do
! loop over output points
do i=1,no
! use recursive algorithm in Eq. (A3) to evaluate function
a0=0.d0
a1=g(1,1)
b0=1.d0
b1=1.d0
do j=2,ni
z1=(zo(i)-zi(j-1))*g(j,j)
z2=a1+z1*a0
a0=a1
a1=z2
z2=b1+z1*b0
b0=b1
b1=z2
! check for overflow and rescale
if ((abs(dble(a1)).gt.1.d100).or.(abs(aimag(a1)).gt.1.d100)) then
t1=1.d0/abs(a1)
a0=a0*t1
b0=b0*t1
a1=a1*t1
b1=b1*t1
end if
if ((abs(dble(b1)).gt.1.d100).or.(abs(aimag(b1)).gt.1.d100)) then
t1=1.d0/abs(b1)
a0=a0*t1
b0=b0*t1
a1=a1*t1
b1=b1*t1
end if
end do
t1=abs(dble(b1))+abs(aimag(b1))
if (t1.ne.0.d0) then
uo(i)=a1/b1
else
uo(i)=0.d0
end if
end do
deallocate(g)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/pades.f90 0000644 0000000 0000000 00000000130 13543334734 014240 x ustar 00 29 mtime=1569569244.43364207
30 atime=1569569240.563644542
29 ctime=1569569244.43364207
elk-6.3.2/src/pades.f90 0000644 0025044 0025044 00000002115 13543334734 016310 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 pades(ns,r,ni,zi,ui,no,zo,uo)
implicit none
! arguments
integer, intent(in) :: ns
real(8), intent(in) :: r
integer, intent(in) :: ni
complex(8), intent(in) :: zi(ni)
complex(8), intent(in) :: ui(ni)
integer, intent(in) :: no
complex(8), intent(in) :: zo(no)
complex(8), intent(out) :: uo(no)
! local variables
integer i
real(8), parameter :: pi=3.1415926535897932385d0
real(8) t1,t2
complex(8) z1
! allocatable arrays
complex(8), allocatable :: u1(:),u2(:)
if (ns.le.0) then
write(*,*)
write(*,'("Error(pades): ns <= 0 : ",I8)') ns
write(*,*)
stop
end if
if (ns.eq.1) then
call pade(ni,zi,ui,no,zo,uo)
return
end if
allocate(u1(ni),u2(no))
uo(:)=0.d0
do i=1,ns
t1=dble(i-1)/dble(ns)
t2=6.d0*pi*t1
z1=r*t1*cmplx(cos(t2),sin(t2),8)
u1(:)=ui(:)+z1
call pade(ni,zi,u1,no,zo,u2)
uo(:)=uo(:)+u2(:)-z1
end do
t1=1.d0/dble(ns)
uo(:)=t1*uo(:)
deallocate(u1,u2)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rfint0.f90 0000644 0000000 0000000 00000000132 13543334734 014350 x ustar 00 30 mtime=1569569244.437642067
30 atime=1569569240.568644539
30 ctime=1569569244.437642067
elk-6.3.2/src/rfint0.f90 0000644 0025044 0025044 00000001400 13543334734 016412 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) rfint
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
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zfinp.f90 0000644 0000000 0000000 00000000132 13543334734 014274 x ustar 00 30 mtime=1569569244.442642064
30 atime=1569569240.573644535
30 ctime=1569569244.442642064
elk-6.3.2/src/zfinp.f90 0000644 0025044 0025044 00000003660 13543334734 016350 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: zfinp
! !INTERFACE:
complex(8) function zfinp(zfmt1,zfir1,zfmt2,zfir2)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! zfmt1 : first complex function in spherical harmonics/coordinates for all
! muffin-tins (in,complex(npcmtmax,natmtot))
! zfir1 : first complex interstitial function in real-space
! (in,complex(ngtc))
! zfmt2 : second complex function in spherical harmonics/coordinates for all
! muffin-tins (in,complex(npcmtmax,natmtot))
! zfir2 : second complex interstitial function in real-space
! (in,complex(ngtc))
! !DESCRIPTION:
! Calculates the inner product of two complex fuctions over the entire unit
! cell. The muffin-tin functions should be stored on the coarse radial grid.
! In the interstitial region, the integrand is multiplied with the
! characteristic function to remove the contribution from the muffin-tin. See
! routines {\tt zfmtinp} and {\tt gencfun}.
!
! !REVISION HISTORY:
! Created July 2004 (Sharma)
!EOP
!BOC
implicit none
! arguments
complex(8), intent(in) :: zfmt1(npcmtmax,natmtot),zfir1(ngtc)
complex(8), intent(in) :: zfmt2(npcmtmax,natmtot),zfir2(ngtc)
! local variables
integer is,ias,ir,nthd
! external functions
complex(8) zfmtinp
external zfmtinp
! interstitial contribution
zfinp=0.d0
do ir=1,ngtc
zfinp=zfinp+cfrc(ir)*conjg(zfir1(ir))*zfir2(ir)
end do
zfinp=zfinp*(omega/dble(ngtc))
! muffin-tin contribution
call holdthd(natmtot,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(is) REDUCTION(+:zfinp) &
!$OMP NUM_THREADS(nthd)
do ias=1,natmtot
is=idxis(ias)
zfinp=zfinp+zfmtinp(nrcmt(is),nrcmti(is),wrcmt(:,is),zfmt1(:,ias), &
zfmt2(:,ias))
end do
!$OMP END PARALLEL DO
call freethd(nthd)
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/symrvf.f90 0000644 0000000 0000000 00000000132 13543334734 014474 x ustar 00 30 mtime=1569569244.446642062
30 atime=1569569240.578644532
30 ctime=1569569244.446642062
elk-6.3.2/src/symrvf.f90 0000644 0025044 0025044 00000004332 13543334734 016545 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: symrvf
! !INTERFACE:
subroutine symrvf(tspin,tnc,nr,nri,np,ld,rvfmt,rvfir)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! tspin : .true. if spin rotations should be used (in,logical)
! tnc : .true. if the vector field is non-collinear, otherwise it is
! collinear along the z-axis (in,logical)
! nr : number of radial points for each species (in,integer(nspecies))
! nri : number of radial points on the inner part (in,integer(nspecies))
! np : total number of points in each muffin-tin (in,integer(nspecies))
! ld : leading dimension (in,integer)
! rvfmt : real muffin-tin vector field (in,real(ld,natmtot,*))
! rvfir : real interstitial vector field (in,real(ngtot,*))
! !DESCRIPTION:
! Symmetrises a vector field defined over the entire unit cell using the full
! set of crystal symmetries. If a particular symmetry involves rotating atom
! 1 into atom 2, then the spatial and spin rotations of that symmetry are
! applied to the vector field in atom 2 (expressed in spherical harmonic
! coefficients), which is then added to the field in atom 1. This is repeated
! for all symmetry operations. The fully symmetrised field in atom 1 is then
! rotated and copied to atom 2. Symmetrisation of the interstitial part of the
! field is performed by {\tt symrvfir}. See also {\tt symrfmt} and
! {\tt findsym}.
!
! !REVISION HISTORY:
! Created May 2007 (JKD)
! Fixed problem with improper rotations, February 2008 (L. Nordstrom,
! F. Bultmark and F. Cricchio)
!EOP
!BOC
implicit none
! arguments
logical, intent(in) :: tspin,tnc
integer, intent(in) :: nr(nspecies),nri(nspecies),np(nspecies)
integer, intent(in) :: ld
real(8), intent(inout) :: rvfmt(ld,natmtot,*),rvfir(ngtot,*)
! local variables
integer nthd
call holdthd(2,nthd)
!$OMP PARALLEL SECTIONS DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP SECTION
call symrvfmt(tspin,tnc,nr,nri,np,ld,rvfmt)
!$OMP SECTION
call symrvfir(tspin,tnc,rvfir)
!$OMP END PARALLEL SECTIONS
call freethd(nthd)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/genapwfr.f90 0000644 0000000 0000000 00000000132 13543334734 014757 x ustar 00 30 mtime=1569569244.451642058
30 atime=1569569240.583644529
30 ctime=1569569244.451642058
elk-6.3.2/src/genapwfr.f90 0000644 0025044 0025044 00000010022 13543334734 017021 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: genapwfr
! !INTERFACE:
subroutine genapwfr
! !USES:
use modmain
! !DESCRIPTION:
! Generates the APW radial functions. This is done by integrating the scalar
! relativistic Schr\"{o}dinger equation (or its energy deriatives) at the
! current linearisation energies using the spherical part of the Kohn-Sham
! potential. The number of radial functions at each $l$-value is given by the
! variable {\tt apword} (at the muffin-tin boundary, the APW functions have
! continuous derivatives up to order ${\tt apword}-1$). Within each $l$, these
! functions are orthonormalised with the Gram-Schmidt method. The radial
! Hamiltonian is applied to the orthonormalised functions and the results are
! stored in the global array {\tt apwfr}.
!
! !REVISION HISTORY:
! Created March 2003 (JKD)
! Copied to equivalent atoms, February 2010 (A. Kozhevnikov and JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ia,ja,ias,jas
integer nr,nri,ir,i
integer nn,l,io,jo
real(8) e,t1
! automatic arrays
logical done(natmmax)
real(8) vr(nrmtmax),fr(nrmtmax)
real(8) p0(nrmtmax,apwordmax),p1(nrmtmax),p1s(apwordmax)
real(8) q0(nrmtmax),q1(nrmtmax),ep0(nrmtmax,apwordmax)
! external functions
real(8) splint
external splint
do is=1,nspecies
nr=nrmt(is)
nri=nrmti(is)
done(:)=.false.
do ia=1,natoms(is)
if (done(ia)) cycle
ias=idxas(ia,is)
! use spherical part of potential
i=1
do ir=1,nri
vr(ir)=vsmt(i,ias)*y00
i=i+lmmaxi
end do
do ir=nri+1,nr
vr(ir)=vsmt(i,ias)*y00
i=i+lmmaxo
end do
do l=0,lmaxapw
do io=1,apword(l,is)
! linearisation energy accounting for energy derivative
e=apwe(io,l,ias)+dble(apwdm(io,l,is))*deapwlo
! integrate the radial Schrodinger equation
call rschrodint(solsc,l,e,nr,rlmt(:,1,is),vr,nn,p0(:,io),p1,q0,q1)
! multiply by the linearisation energy
ep0(1:nr,io)=e*p0(1:nr,io)
! normalise radial functions
fr(1:nr)=p0(1:nr,io)**2
t1=splint(nr,rlmt(:,1,is),fr)
t1=1.d0/sqrt(abs(t1))
call dscal(nr,t1,p0(:,io),1)
p1s(io)=t1*p1(nr)
call dscal(nr,t1,ep0(:,io),1)
! subtract linear combination of previous vectors
do jo=1,io-1
fr(1:nr)=p0(1:nr,io)*p0(1:nr,jo)
t1=-splint(nr,rlmt(:,1,is),fr)
call daxpy(nr,t1,p0(:,jo),1,p0(:,io),1)
p1s(io)=p1s(io)+t1*p1s(jo)
call daxpy(nr,t1,ep0(:,jo),1,ep0(:,io),1)
end do
! normalise radial functions again
fr(1:nr)=p0(1:nr,io)**2
t1=splint(nr,rlmt(:,1,is),fr)
t1=abs(t1)
if (t1.lt.1.d-25) then
write(*,*)
write(*,'("Error(genapwfr): degenerate APW radial functions")')
write(*,'(" for species ",I4)') is
write(*,'(" atom ",I4)') ia
write(*,'(" angular momentum ",I4)') l
write(*,'(" and order ",I4)') io
write(*,*)
stop
end if
t1=1.d0/sqrt(t1)
call dscal(nr,t1,p0(:,io),1)
p1s(io)=t1*p1s(io)
call dscal(nr,t1,ep0(:,io),1)
! divide by r and store in global array
do ir=1,nr
t1=rlmt(ir,-1,is)
apwfr(ir,1,io,l,ias)=t1*p0(ir,io)
apwfr(ir,2,io,l,ias)=t1*ep0(ir,io)
end do
! derivative at the muffin-tin surface
apwdfr(io,l,ias)=(p1s(io)-p0(nr,io)*t1)*t1
end do
end do
done(ia)=.true.
! copy to equivalent atoms
do ja=1,natoms(is)
if ((.not.done(ja)).and.(eqatoms(ia,ja,is))) then
jas=idxas(ja,is)
do l=0,lmaxapw
do io=1,apword(l,is)
call dcopy(nr,apwfr(:,1,io,l,ias),1,apwfr(:,1,io,l,jas),1)
call dcopy(nr,apwfr(:,2,io,l,ias),1,apwfr(:,2,io,l,jas),1)
apwdfr(io,l,jas)=apwdfr(io,l,ias)
end do
end do
done(ja)=.true.
end if
end do
! end loop over atoms and species
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rfcopy.f90 0000644 0000000 0000000 00000000132 13543334734 014450 x ustar 00 30 mtime=1569569244.455642056
30 atime=1569569240.589644525
30 ctime=1569569244.455642056
elk-6.3.2/src/rfcopy.f90 0000644 0025044 0025044 00000001047 13543334734 016521 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 rfcopy(rfmt1,rfir1,rfmt2,rfir2)
use modmain
implicit none
! arguments
real(8), intent(in) :: rfmt1(npmtmax,natmtot),rfir1(ngtot)
real(8), intent(out) :: rfmt2(npmtmax,natmtot),rfir2(ngtot)
! local variables
integer is,ias
do ias=1,natmtot
is=idxis(ias)
rfmt2(1:npmt(is),ias)=rfmt1(1:npmt(is),ias)
end do
rfir2(:)=rfir1(:)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rhomagsh.f90 0000644 0000000 0000000 00000000132 13543334734 014756 x ustar 00 30 mtime=1569569244.459642053
30 atime=1569569240.594644522
30 ctime=1569569244.459642053
elk-6.3.2/src/rhomagsh.f90 0000644 0025044 0025044 00000002374 13543334734 017033 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,nthd
integer nrc,nrci,npc
! allocatable arrays
real(8), allocatable :: rfmt(:)
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(rfmt,is,nrc,nrci,npc,idm) &
!$OMP NUM_THREADS(nthd)
allocate(rfmt(npcmtmax))
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
! convert the density to spherical harmonics
call dcopy(npc,rhomt(:,ias),1,rfmt,1)
call rfsht(nrc,nrci,rfmt,rhomt(:,ias))
! convert magnetisation to spherical harmonics
do idm=1,ndmag
call dcopy(npc,magmt(:,ias,idm),1,rfmt,1)
call rfsht(nrc,nrci,rfmt,magmt(:,ias,idm))
end do
end do
!$OMP END DO
deallocate(rfmt)
!$OMP END PARALLEL
call freethd(nthd)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/genylmg.f90 0000644 0000000 0000000 00000000132 13543334734 014610 x ustar 00 30 mtime=1569569244.463642051
30 atime=1569569240.598644519
30 ctime=1569569244.463642051
elk-6.3.2/src/genylmg.f90 0000644 0025044 0025044 00000001361 13543334734 016660 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: genylmg
! !INTERFACE:
subroutine genylmg
! !USES:
use modmain
! !DESCRIPTION:
! Generates a set of spherical harmonics, $Y_{lm}(\hat{\bf G})$, with angular
! momenta up to {\tt lmaxo} for the set of ${\bf G}$-vectors.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer ig
! allocate global G-vector spherical harmonic array
if (allocated(ylmg)) deallocate(ylmg)
allocate(ylmg(lmmaxo,ngvec))
do ig=1,ngvec
call genylmv(lmaxo,vgc(:,ig),ylmg(:,ig))
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/olpaa.f90 0000644 0000000 0000000 00000000132 13543334734 014242 x ustar 00 30 mtime=1569569244.468642048
30 atime=1569569240.603644516
30 ctime=1569569244.468642048
elk-6.3.2/src/olpaa.f90 0000644 0025044 0025044 00000001503 13543334734 016310 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,ias,ngp,apwalm,ld,o)
use modmain
implicit none
! arguments
logical, intent(in) :: tor
integer, intent(in) :: ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: o(*)
! local variables
integer is,lmo,io
integer l,m,lm,i
! allocatable arrays
complex(8), allocatable :: a(:,:)
is=idxis(ias)
lmo=lmoapw(is)
allocate(a(lmo,ngp))
i=0
lm=0
do l=0,lmaxapw
do m=-l,l
lm=lm+1
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,lmo,ngp,a,a,ld,o)
deallocate(a)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/readfermi.f90 0000644 0000000 0000000 00000000132 13543334734 015104 x ustar 00 30 mtime=1569569244.472642045
30 atime=1569569240.608644513
30 ctime=1569569244.472642045
elk-6.3.2/src/readfermi.f90 0000644 0025044 0025044 00000001557 13543334734 017163 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: readfermi
! !INTERFACE:
subroutine readfermi
! !USES:
use modmain
! !DESCRIPTION:
! Reads the Fermi energy from the file {\tt EFERMI.OUT}.
!
! !REVISION HISTORY:
! Created March 2005 (JKD)
!EOP
!BOC
implicit none
! local variables
integer ios
open(50,file='EFERMI'//trim(filext),form='FORMATTED',status='OLD',iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readfermi): error opening ",A)') 'EFERMI'//trim(filext)
write(*,*)
stop
end if
read(50,*,iostat=ios) efermi
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readfermi): error reading Fermi energy from EFERMI.OUT")')
write(*,*)
stop
end if
close(50)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/factr.f90 0000644 0000000 0000000 00000000131 13543334734 014244 x ustar 00 30 mtime=1569569244.476642043
29 atime=1569569240.61364451
30 ctime=1569569244.476642043
elk-6.3.2/src/factr.f90 0000644 0025044 0025044 00000002211 13543334734 016310 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: factr
! !INTERFACE:
real(8) function factr(n,d)
! !INPUT/OUTPUT PARAMETERS:
! n : numerator (in,integer)
! d : denominator (in,integer)
! !DESCRIPTION:
! Returns the ratio $n!/d!$ for $n,d\ge 0$. Performs no under- or overflow
! checking.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: n,d
! local variables
integer i
! external functions
real(8) factnm
external factnm
if (d.eq.1) then
factr=factnm(n,1)
return
end if
if (n.lt.0) then
write(*,*)
write(*,'("Error(factr): n < 0 : ",I8)') n
write(*,*)
stop
end if
if (d.lt.0) then
write(*,*)
write(*,'("Error(factr): d < 0 : ",I8)') d
write(*,*)
stop
end if
if (n.lt.d) then
factr=dble(n+1)
do i=n+2,d
factr=factr*dble(i)
end do
factr=1.d0/factr
else if (n.eq.d) then
factr=1.d0
else
factr=dble(d+1)
do i=d+2,n
factr=factr*dble(i)
end do
end if
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/writechg.f90 0000644 0000000 0000000 00000000132 13543334734 014762 x ustar 00 30 mtime=1569569244.481642039
30 atime=1569569240.618644507
30 ctime=1569569244.481642039
elk-6.3.2/src/writechg.f90 0000644 0025044 0025044 00000002260 13543334734 017031 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 Lesser General Public
! License. See the file COPYING for license details.
subroutine writechg(fnum)
use modmain
implicit none
! arguments
integer, intent(in) :: fnum
! local variables
integer is,ia,ias
! write charges
write(fnum,*)
write(fnum,'("Charges :")')
write(fnum,'(" core",T30,": ",G18.10)') chgcrtot
write(fnum,'(" valence",T30,": ",G18.10)') chgval
write(fnum,'(" interstitial",T30,": ",G18.10)') chgir
write(fnum,'(" muffin-tins (core leakage)")')
do is=1,nspecies
write(fnum,'(" species : ",I4," (",A,")")') is,trim(spsymb(is))
do ia=1,natoms(is)
ias=idxas(ia,is)
write(fnum,'(" atom ",I4,T30,": ",G18.10," (",G18.10,")")') ia, &
chgmt(ias),chgcrlk(ias)
end do
end do
write(fnum,'(" total in muffin-tins",T30,": ",G18.10)') chgmttot
if (chgexs.ne.0.d0) then
write(fnum,'(" excess",T30,": ",G18.10)') chgexs
end if
write(fnum,'(" total calculated charge",T30,": ",G18.10)') chgcalc
write(fnum,'(" total charge",T30,": ",G18.10)') chgtot
write(fnum,'(" error",T30,": ",G18.10)') abs(chgtot-chgcalc)
flush(fnum)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zflmconj.f90 0000644 0000000 0000000 00000000132 13543334734 014770 x ustar 00 30 mtime=1569569244.485642037
30 atime=1569569240.623644503
30 ctime=1569569244.485642037
elk-6.3.2/src/zflmconj.f90 0000644 0025044 0025044 00000003003 13543334734 017033 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: zflmconj
! !INTERFACE:
pure subroutine zflmconj(lmax,zflm1,zflm2)
! !INPUT/OUTPUT PARAMETERS:
! lmax : maximum angular momentum (in,integer)
! zflm1 : coefficients of input complex spherical harmonic expansion
! (in,complex((lmax+1)**2)))
! zflm2 : coefficients of output complex spherical harmonic expansion
! (out,complex((lmax+1)**2)))
! !DESCRIPTION:
! Returns the complex conjugate of a function expanded in spherical harmonics.
! In other words, given the input function coefficients $z_{lm}$, the routine
! returns $z'_{lm}=(-1)^m z^*_{l-m}$ so that
! $$ \sum_{lm}z'_{lm}Y_{lm}(\theta,\phi)=\left(\sum_{lm}z_{lm}Y_{lm}
! (\theta,\phi)\right)^* $$
! for all $(\theta,\phi)$.
!
! !REVISION HISTORY:
! Created April 2004 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: lmax
complex(8), intent(in) :: zflm1(*)
complex(8), intent(out) :: zflm2(*)
! local variables
integer l,m,lm1,lm2
do l=0,lmax
lm1=l**2
lm2=(l+1)**2+1
do m=-l,-1
lm1=lm1+1
lm2=lm2-1
if (mod(m,2).eq.0) then
zflm2(lm1)=conjg(zflm1(lm2))
zflm2(lm2)=conjg(zflm1(lm1))
else
zflm2(lm1)=-conjg(zflm1(lm2))
zflm2(lm2)=-conjg(zflm1(lm1))
end if
end do
! m=0 case
lm1=lm1+1
zflm2(lm1)=conjg(zflm1(lm1))
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rminv.f90 0000644 0000000 0000000 00000000130 13543334734 014277 x ustar 00 30 mtime=1569569244.489642034
28 atime=1569569240.6286445
30 ctime=1569569244.489642034
elk-6.3.2/src/rminv.f90 0000644 0025044 0025044 00000001437 13543334734 016355 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 rminv(n,a)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(inout) :: a(n,n)
! local variables
integer info
! automatic arrays
integer ipiv(n)
real(8) work(n)
call dgetrf(n,n,a,n,ipiv,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(rminv): unable to invert matrix")')
write(*,'(" DGETRF returned INFO = ",I8)') info
write(*,*)
stop
end if
call dgetri(n,a,n,ipiv,work,n,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(rminv): unable to invert matrix")')
write(*,'(" DGETRI returned INFO = ",I8)') info
write(*,*)
stop
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zminv.f90 0000644 0000000 0000000 00000000132 13543334734 014311 x ustar 00 30 mtime=1569569244.494642031
30 atime=1569569240.634644496
30 ctime=1569569244.494642031
elk-6.3.2/src/zminv.f90 0000644 0025044 0025044 00000001671 13543334734 016365 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 zminv(n,a)
use modomp
implicit none
! arguments
integer, intent(in) :: n
complex(8), intent(inout) :: a(n,n)
! local variables
integer info,nthd
! automatic arrays
integer ipiv(n)
complex(8) work(n)
! enable MKL parallelism
call holdthd(maxthdmkl,nthd)
call mkl_set_num_threads(nthd)
call zgetrf(n,n,a,n,ipiv,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(zminv): unable to invert matrix")')
write(*,'(" ZGETRF returned INFO = ",I8)') info
write(*,*)
stop
end if
call zgetri(n,a,n,ipiv,work,n,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(zminv): unable to invert matrix")')
write(*,'(" ZGETRI returned INFO = ",I8)') info
write(*,*)
stop
end if
call freethd(nthd)
call mkl_set_num_threads(1)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rlmrot.f90 0000644 0000000 0000000 00000000132 13543334734 014465 x ustar 00 30 mtime=1569569244.498642028
30 atime=1569569240.639644493
30 ctime=1569569244.498642028
elk-6.3.2/src/rlmrot.f90 0000644 0025044 0025044 00000007477 13543334734 016553 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2008 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: rlmrot
! !INTERFACE:
subroutine rlmrot(p,ang,lmax,ld,d)
! !INPUT/OUTPUT PARAMETERS:
! p : if p=-1 then the rotation matrix is improper (in,integer)
! ang : Euler angles; alpha, beta, gamma (in,real(3))
! lmax : maximum angular momentum (in,integer)
! ld : leading dimension (in,integer)
! d : real spherical harmonic rotation matrix (out,real(ld,*))
! !DESCRIPTION:
! Returns the rotation matrix in the basis of real spherical harmonics given
! the three Euler angles, $(\alpha,\beta,\gamma)$, and the parity, $p$, of the
! rotation. The matrix is determined using the formula of V. V. Nechaev,
! [{\it J. Struct. Chem.} {\bf 35}, 115 (1994)], suitably modified for our
! definition of the real spherical harmonics ($m_1>0$, $m_2>0$):
! \begin{align*}
! &\Delta^l_{00}=d^l_{00}, \\
! &\Delta^l_{m_10}=\sqrt{2}\,(-1)^{m_1}d^l_{0m_1}\cos(m_1\alpha), \\
! &\Delta^l_{0m_2}=\sqrt{2}\,(-1)^{m_2}d^l_{m_20}\cos(m_2\gamma), \\
! &\Delta^l_{-m_10}=-\sqrt{2}\,d^l_{0m_1}\sin(m_1\alpha), \\
! &\Delta^l_{0-m_2}=\sqrt{2}\,d^l_{m_20}\sin(m_2\gamma), \\
! &\Delta^l_{m_1m_2}=(-1)^{m_1}(-1)^{m_2}\{\cos(m_1\alpha)\cos(m_2\gamma)
! [d_A+d_B]-\sin(m_1\alpha)\sin(m_2\gamma)[d_A-d_B]\}, \\
! &\Delta^l_{m_1-m_2}=(-1)^{m_1}\{\sin(m_1\alpha)\cos(m_2\gamma)
! [d_A-d_B]+\cos(m_1\alpha)\sin(m_2\gamma)[d_A+d_B]\}, \\
! &\Delta^l_{-m_1m_2}=-(-1)^{m_2}\{\sin(m_1\alpha)\cos(m_2\gamma)
! [d_A+d_B]+\cos(m_1\alpha)\sin(m_2\gamma)[d_A-d_B]\}, \\
! &\Delta^l_{-m_1-m_2}=\cos(m_1\alpha)\cos(m_2\gamma)
! [d_A-d_B]-\sin(m_1\alpha)\sin(m_2\gamma)[d_A+d_B],
! \end{align*}
! where $d_A\equiv d^l_{-m_1-m_2}$, $d_B\equiv(-1)^{m_1}d^l_{m_1-m_2}$ and
! $d$ is the rotation matrix about the $y$-axis for complex spherical
! harmonics. See the routines {\tt genrlm}, {\tt roteuler} and {\tt ylmroty}.
!
! !REVISION HISTORY:
! Created December 2008 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: p
real(8), intent(in) :: ang(3)
integer, intent(in) :: lmax,ld
real(8), intent(out) :: d(ld,*)
! local variables
integer l,m1,m2,lm0,lm1,lm2
real(8), parameter :: sqtwo=1.4142135623730950488d0
real(8) s1,s2,t1,t2,t3,t4,t5,t6,t7,t8
! automatic arrays
integer lmi(-lmax:lmax)
real(8) ca(lmax),sa(lmax)
real(8) cg(lmax),sg(lmax)
real(8) dy(ld,ld)
if (lmax.lt.0) then
write(*,*)
write(*,'("Error(rlmrot): lmax < 0 : ",I8)') lmax
write(*,*)
stop
end if
! generate the complex spherical harmonic rotation matrix about the y-axis
call ylmroty(ang(2),lmax,ld,dy)
do m1=1,lmax
ca(m1)=cos(m1*ang(1))
sa(m1)=sin(m1*ang(1))
cg(m1)=cos(m1*ang(3))
sg(m1)=sin(m1*ang(3))
end do
lm1=0
do l=0,lmax
do m1=-l,l
lm1=lm1+1
lmi(m1)=lm1
end do
lm0=lmi(0)
d(lm0,lm0)=dy(lm0,lm0)
do m1=1,l
if (mod(m1,2).eq.0) then
s1=1.d0
else
s1=-1.d0
end if
t1=sqtwo*dy(lm0,lmi(m1))
t2=sqtwo*dy(lmi(m1),lm0)
d(lmi(m1),lm0)=s1*t1*ca(m1)
d(lm0,lmi(m1))=s1*t2*cg(m1)
d(lmi(-m1),lm0)=-t1*sa(m1)
d(lm0,lmi(-m1))=t2*sg(m1)
do m2=1,l
if (mod(m2,2).eq.0) then
s2=1.d0
else
s2=-1.d0
end if
t1=ca(m1)*cg(m2)
t2=sa(m1)*sg(m2)
t3=sa(m1)*cg(m2)
t4=ca(m1)*sg(m2)
t5=dy(lmi(-m1),lmi(-m2))
t6=s1*dy(lmi(m1),lmi(-m2))
t7=t5+t6
t8=t5-t6
d(lmi(m1),lmi(m2))=s1*s2*(t1*t7-t2*t8)
d(lmi(m1),lmi(-m2))=s1*(t3*t8+t4*t7)
d(lmi(-m1),lmi(m2))=-s2*(t3*t7+t4*t8)
d(lmi(-m1),lmi(-m2))=t1*t8-t2*t7
end do
end do
end do
! apply inversion if required
if (p.eq.-1) then
do l=1,lmax,2
lm1=l**2+1
lm2=lm1+2*l
d(lm1:lm2,lm1:lm2)=-d(lm1:lm2,lm1:lm2)
end do
end if
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rotrflm.f90 0000644 0000000 0000000 00000000132 13543334734 014633 x ustar 00 30 mtime=1569569244.502642026
30 atime=1569569240.643644491
30 ctime=1569569244.502642026
elk-6.3.2/src/rotrflm.f90 0000644 0025044 0025044 00000004576 13543334734 016716 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2008 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: rotrflm
! !INTERFACE:
subroutine rotrflm(rot,lmax,n,ld,rflm1,rflm2)
! !INPUT/OUTPUT PARAMETERS:
! rot : rotation matrix (in,real(3,3))
! lmax : maximum angular momentum (in,integer)
! n : number of functions to rotate (in,integer)
! ld : leading dimension (in,integer)
! rflm1 : coefficients of the real spherical harmonic expansion for each
! function (in,real(ld,n))
! rflm2 : coefficients of rotated functions (out,complex(ld,n))
! !DESCRIPTION:
! Rotates a set of real functions
! $$ f_i({\bf r})=\sum_{lm}f_{lm}^iR_{lm}(\hat{\bf r}) $$
! for all $i$, given the coefficients $f_{lm}^i$ and a rotation matrix $R$.
! This is done by first the computing the Euler angles $(\alpha,\beta,\gamma)$
! of $R^{-1}$ (see routine {\tt roteuler}) and then applying the spherical
! harmonic rotation matrix generated by the routine {\tt rlmrot}.
!
! !REVISION HISTORY:
! Created December 2008 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rot(3,3)
integer, intent(in) :: lmax,n,ld
real(8), intent(in) :: rflm1(ld,*)
real(8), intent(out) :: rflm2(ld,*)
! local variables
integer l,lm,nm,p
real(8) det,rotp(3,3)
real(8) ang(3),angi(3)
! automatic arrays
real(8) d(ld,ld)
if (lmax.lt.0) then
write(*,*)
write(*,'("Error(rotrflm): lmax < 0 : ",I8)') lmax
write(*,*)
stop
end if
if (n.eq.0) return
if (n.lt.0) then
write(*,*)
write(*,'("Error(rotrflm): n < 0 : ",I8)') n
write(*,*)
stop
end if
! find the determinant
det=rot(1,2)*rot(2,3)*rot(3,1)-rot(1,3)*rot(2,2)*rot(3,1) &
+rot(1,3)*rot(2,1)*rot(3,2)-rot(1,1)*rot(2,3)*rot(3,2) &
+rot(1,1)*rot(2,2)*rot(3,3)-rot(1,2)*rot(2,1)*rot(3,3)
! make the rotation proper
p=1
if (det.lt.0.d0) p=-1
rotp(:,:)=dble(p)*rot(:,:)
! compute the Euler angles of the rotation matrix
call roteuler(rotp,ang)
! inverse rotation: the function is to be rotated, not the spherical harmonics
angi(1)=-ang(3)
angi(2)=-ang(2)
angi(3)=-ang(1)
! determine the rotation matrix for real spherical harmonics
call rlmrot(p,angi,lmax,ld,d)
! apply rotation matrix
do l=0,lmax
nm=2*l+1
lm=l**2+1
call dgemm('N','N',nm,n,nm,1.d0,d(lm,lm),ld,rflm1(lm,1),ld,0.d0,rflm2(lm,1), &
ld)
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ztorflm.f90 0000644 0000000 0000000 00000000132 13543334734 014643 x ustar 00 30 mtime=1569569244.507642023
30 atime=1569569240.648644488
30 ctime=1569569244.507642023
elk-6.3.2/src/ztorflm.f90 0000644 0025044 0025044 00000003343 13543334734 016715 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: ztorflm
! !INTERFACE:
pure subroutine ztorflm(lmax,zflm,rflm)
! !INPUT/OUTPUT PARAMETERS:
! lmax : maximum angular momentum (in,integer)
! zflm : coefficients of complex spherical harmonic expansion
! (in,complex((lmax+1)**2)))
! rflm : coefficients of real spherical harmonic expansion
! (out,real((lmax+1)**2)))
! !DESCRIPTION:
! Converts a real function, $z_{lm}$, expanded in terms of complex spherical
! harmonics into a real spherical harmonic expansion, $r_{lm}$:
! $$ r_{lm}=\begin{cases}\frac{1}{\sqrt{2}}\Re(z_{lm}+(-1)^m z_{l-m}) & m>0 \\
! \frac{1}{\sqrt{2}}\Im(-z_{lm}+(-1)^m z_{l-m}) & m<0 \\
! \Re(z_{lm}) & m=0 \end{cases}\;. $$
! See routine {\tt genrlm}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: lmax
complex(8), intent(in) :: zflm(*)
real(8), intent(out) :: rflm(*)
! local variables
integer l,m,lm1,lm2
! real constant 1/sqrt(2)
real(8), parameter :: c1=0.7071067811865475244d0
lm1=0
do l=0,lmax
lm2=lm1+2*(l+1)
do m=-l,-1
lm1=lm1+1
lm2=lm2-1
if (mod(m,2).ne.0) then
rflm(lm1)=-c1*(aimag(zflm(lm1))+aimag(zflm(lm2)))
else
rflm(lm1)=c1*(aimag(zflm(lm2))-aimag(zflm(lm1)))
end if
end do
lm1=lm1+1
lm2=lm2-1
rflm(lm1)=dble(zflm(lm1))
do m=1,l
lm1=lm1+1
lm2=lm2-1
if (mod(m,2).ne.0) then
rflm(lm1)=c1*(dble(zflm(lm1))-dble(zflm(lm2)))
else
rflm(lm1)=c1*(dble(zflm(lm1))+dble(zflm(lm2)))
end if
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rotzflm.f90 0000644 0000000 0000000 00000000130 13543334734 014641 x ustar 00 29 mtime=1569569244.51164202
30 atime=1569569240.653644484
29 ctime=1569569244.51164202
elk-6.3.2/src/rotzflm.f90 0000644 0025044 0025044 00000005526 13543334734 016722 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2008 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: rotzflm
! !INTERFACE:
subroutine rotzflm(rot,lmin,lmax,lmmax,n,ld,zflm1,zflm2)
! !INPUT/OUTPUT PARAMETERS:
! rot : rotation matrix (in,real(3,3))
! lmin : minimum angular momentum (in,integer)
! lmax : maximum angular momentum (in,integer)
! lmmax : (lmax+1)^2 or larger (in,integer)
! n : number of functions to rotate (in,integer)
! ld : leading dimension (in,integer)
! zflm1 : coefficients of the complex spherical harmonic expansion for each
! function (in,complex(ld,n))
! zflm2 : coefficients of rotated functions (out,complex(ld,n))
! !DESCRIPTION:
! Rotates a set of complex functions
! $$ f_i({\bf r})=\sum_{lm}f_{lm}^iY_{lm}(\hat{\bf r}) $$
! for all $i$, given the coefficients $f_{lm}^i$ and a rotation matrix $R$.
! This is done by first the computing the Euler angles $(\alpha,\beta,\gamma)$
! of $R^{-1}$ (see routine {\tt roteuler}) and then applying the spherical
! harmonic rotation matrix generated by the routine {\tt ylmrot}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
! Modified, December 2008 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rot(3,3)
integer, intent(in) :: lmin,lmax,lmmax,n,ld
complex(8), intent(in) :: zflm1(ld,n)
complex(8), intent(out) :: zflm2(ld,n)
! local variables
integer l,lm1,lm2,nm,p
real(8) det,rotp(3,3)
real(8) ang(3),angi(3)
complex(8), parameter :: zzero=(0.d0,0.d0),zone=(1.d0,0.d0)
! automatic arrays
complex(8) d(lmmax,lmmax)
if (lmin.lt.0) then
write(*,*)
write(*,'("Error(rotzflm): lmin < 0 : ",I8)') lmin
write(*,*)
stop
end if
if (lmin.gt.lmax) then
write(*,*)
write(*,'("Error(rotzflm): lmin > lmax : ",2I8)') lmin,lmax
write(*,*)
stop
end if
if (n.eq.0) return
if (n.lt.0) then
write(*,*)
write(*,'("Error(rotzflm): n < 0 : ",I8)') n
write(*,*)
stop
end if
! find the determinant
det=rot(1,2)*rot(2,3)*rot(3,1)-rot(1,3)*rot(2,2)*rot(3,1) &
+rot(1,3)*rot(2,1)*rot(3,2)-rot(1,1)*rot(2,3)*rot(3,2) &
+rot(1,1)*rot(2,2)*rot(3,3)-rot(1,2)*rot(2,1)*rot(3,3)
! make the rotation proper
p=1
if (det.lt.0.d0) p=-1
rotp(:,:)=dble(p)*rot(:,:)
! compute the Euler angles of the rotation matrix
call roteuler(rotp,ang)
! inverse rotation: the function is to be rotated, not the spherical harmonics
angi(1)=-ang(3)
angi(2)=-ang(2)
angi(3)=-ang(1)
! determine the rotation matrix for complex spherical harmonics
call ylmrot(p,angi,lmax,lmmax,d)
! apply rotation matrix (d and zflm may have different starting indices)
lm1=lmin**2+1
lm2=1
do l=lmin,lmax
nm=2*l+1
call zgemm('N','N',nm,n,nm,zone,d(lm1,lm1),lmmax,zflm1(lm2,1),ld,zzero, &
zflm2(lm2,1),ld)
lm1=lm1+nm
lm2=lm2+nm
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rfmtlm.f90 0000644 0000000 0000000 00000000132 13543334734 014447 x ustar 00 30 mtime=1569569244.515642018
30 atime=1569569240.658644481
30 ctime=1569569244.515642018
elk-6.3.2/src/rfmtlm.f90 0000644 0025044 0025044 00000001255 13543334734 016521 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 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 rfmtlm(lm,nr,nri,rfmt,fr)
use modmain
implicit none
! arguments
integer, intent(in) :: lm,nr,nri
real(8), intent(in) :: rfmt(npmtmax)
real(8), intent(out) :: fr(nrmtmax)
! local variables
integer iro,ir,i
if (lm.gt.lmmaxi) then
fr(1:nri)=0.d0
else
i=lm
do ir=1,nri
fr(ir)=rfmt(i)
i=i+lmmaxi
end do
end if
iro=nri+1
if (lm.gt.lmmaxo) then
fr(iro:nr)=0.d0
else
i=lmmaxi*nri+lm
do ir=iro,nr
fr(ir)=rfmt(i)
i=i+lmmaxo
end do
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genzrm.f90 0000644 0000000 0000000 00000000132 13543334734 014450 x ustar 00 30 mtime=1569569244.520642014
30 atime=1569569240.663644478
30 ctime=1569569244.520642014
elk-6.3.2/src/genzrm.f90 0000644 0025044 0025044 00000002242 13543334734 016517 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 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.
pure subroutine genzrm(n,wf11,wf12,wf21,wf22,zrho,ld,zmag)
use modmain
implicit none
! arguments
integer, intent(in) :: n
complex(8), intent(in) :: wf11(n),wf12(n),wf21(n),wf22(n)
complex(8), intent(out) :: zrho(n)
integer, intent(in) :: ld
complex(8), intent(out) :: zmag(ld,ndmag)
! local variables
integer i
complex(8) z11,z12,z21,z22,z1,z2
if (ncmag) then
! non-collinear case
do i=1,n
z11=wf11(i)
z12=wf12(i)
z21=wf21(i)
z22=wf22(i)
! up-dn spin density
z1=conjg(z11)*z22
! dn-up spin density
z2=conjg(z12)*z21
! x-component: up-dn + dn-up
zmag(i,1)=z1+z2
! y-component: i*(dn-up - up-dn)
z1=z2-z1
zmag(i,2)=cmplx(-aimag(z1),dble(z1),8)
z1=conjg(z11)*z21
z2=conjg(z12)*z22
! z-component: up-up - dn-dn
zmag(i,3)=z1-z2
! density: up-up + dn-dn
zrho(i)=z1+z2
end do
else
! collinear case
do i=1,n
z1=conjg(wf11(i))*wf21(i)
z2=conjg(wf12(i))*wf22(i)
zmag(i,1)=z1-z2
zrho(i)=z1+z2
end do
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gensfacgp.f90 0000644 0000000 0000000 00000000132 13543334734 015103 x ustar 00 30 mtime=1569569244.524642012
30 atime=1569569240.668644475
30 ctime=1569569244.524642012
elk-6.3.2/src/gensfacgp.f90 0000644 0025044 0025044 00000003012 13543334734 017146 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: gensfacgp
! !INTERFACE:
subroutine gensfacgp(ngp,vgpc,ld,sfacgp)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! ngp : number of G+p-vectors (in,integer)
! vgpc : G+p-vectors in Cartesian coordinates (in,real(3,*))
! ld : leading dimension (in,integer)
! sfacgp : structure factors of G+p-vectors (out,complex(ld,natmtot))
! !DESCRIPTION:
! Generates the atomic structure factors for a set of ${\bf G+p}$-vectors:
! $$ S_{\alpha}({\bf G+p})=\exp(i({\bf G+p})\cdot{\bf r}_{\alpha}), $$
! where ${\bf r}_{\alpha}$ is the position of atom $\alpha$.
!
! !REVISION HISTORY:
! Created January 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ngp
real(8), intent(in) :: vgpc(3,ngp)
integer, intent(in) :: ld
complex(8), intent(out) :: sfacgp(ld,natmtot)
! local variables
integer is,ia,ias
integer igp,nthd
real(8) v1,v2,v3,t1
call holdthd(natmtot,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(is,ia,v1,v2,v3) &
!$OMP PRIVATE(igp,t1) &
!$OMP NUM_THREADS(nthd)
do ias=1,natmtot
is=idxis(ias)
ia=idxia(ias)
v1=atposc(1,ia,is); v2=atposc(2,ia,is); v3=atposc(3,ia,is)
do igp=1,ngp
t1=vgpc(1,igp)*v1+vgpc(2,igp)*v2+vgpc(3,igp)*v3
sfacgp(igp,ias)=cmplx(cos(t1),sin(t1),8)
end do
end do
!$OMP END PARALLEL DO
call freethd(nthd)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/zmctmu.f90 0000644 0000000 0000000 00000000132 13543334734 014465 x ustar 00 30 mtime=1569569244.528642009
30 atime=1569569240.673644472
30 ctime=1569569244.528642009
elk-6.3.2/src/zmctmu.f90 0000644 0025044 0025044 00000002212 13543334734 016531 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 zmctmu(tcr,l,n,a,b,ld,c)
use modomp
implicit none
! arguments
logical, intent(in) :: tcr
integer, intent(in) :: l,n
complex(8), intent(in) :: a(l,n),b(l,n)
integer, intent(in) :: ld
complex(8), intent(out) :: c(*)
! local variables
integer l2,i,j,k,nthd
! external functions
real(8) ddot
complex(8) zdotc
external ddot,zdotc
if (tcr) then
! matrix c is real valued
l2=2*l
call holdthd(n,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(k,i) &
!$OMP NUM_THREADS(nthd)
do j=1,n
k=(j-1)*ld
do i=1,j
k=k+1
c(k)=c(k)+ddot(l2,a(:,i),1,b(:,j),1)
end do
end do
!$OMP END PARALLEL DO
call freethd(nthd)
else
! matrix c is complex valued
call holdthd(n,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(k,i) &
!$OMP NUM_THREADS(nthd)
do j=1,n
k=(j-1)*ld
do i=1,j
k=k+1
c(k)=c(k)+zdotc(l,a(:,i),1,b(:,j),1)
end do
end do
!$OMP END PARALLEL DO
call freethd(nthd)
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zmctm.f90 0000644 0000000 0000000 00000000132 13543334734 014300 x ustar 00 30 mtime=1569569244.533642006
30 atime=1569569240.679644468
30 ctime=1569569244.533642006
elk-6.3.2/src/zmctm.f90 0000644 0025044 0025044 00000001350 13543334734 016346 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 zmctm(l,m,n,a,b,ld,c)
use modomp
implicit none
! arguments
integer, intent(in) :: l,m,n
complex(8), intent(in) :: a(l,m),b(l,n)
integer, intent(in) :: ld
complex(8), intent(out) :: c(*)
! local variables
integer i,j,k,nthd
! external functions
complex(8) zdotc
external zdotc
call holdthd(n,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(k,i) &
!$OMP NUM_THREADS(nthd)
do j=1,n
k=(j-1)*ld
do i=1,m
k=k+1
c(k)=c(k)+zdotc(l,a(:,i),1,b(:,j),1)
end do
end do
!$OMP END PARALLEL DO
call freethd(nthd)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmlfv.f90 0000644 0000000 0000000 00000000132 13543334734 014262 x ustar 00 30 mtime=1569569244.537642004
30 atime=1569569240.684644465
30 ctime=1569569244.537642004
elk-6.3.2/src/hmlfv.f90 0000644 0025044 0025044 00000002232 13543334734 016330 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 hmlfv(nmatp,ngp,igpig,vgpc,apwalm,h)
use modmain
use modomp
implicit none
! arguments
integer, intent(in) :: nmatp,ngp,igpig(ngkmax)
real(8), intent(in) :: vgpc(3,ngkmax)
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw,natmtot)
complex(8), intent(out) :: h(nmatp,nmatp)
! local variables
integer ias,i
integer nthd1,nthd2
! zero the upper triangular part of the matrix
do i=1,nmatp
h(1:i,i)=0.d0
end do
call holdthd(2,nthd1)
!$OMP PARALLEL SECTIONS DEFAULT(SHARED) &
!$OMP PRIVATE(ias) &
!$OMP NUM_THREADS(nthd1)
!$OMP SECTION
do ias=1,natmtot
call hmlaa(tefvr,ias,ngp,apwalm(:,:,:,ias),nmatp,h)
end do
call hmlistl(ngp,igpig,vgpc,nmatp,h)
!$OMP SECTION
call holdthd(natmtot,nthd2)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd2)
do ias=1,natmtot
call hmlalo(ias,ngp,apwalm(:,:,:,ias),nmatp,h)
call hmllolo(ias,ngp,nmatp,h)
end do
!$OMP END PARALLEL DO
call freethd(nthd2)
!$OMP END PARALLEL SECTIONS
call freethd(nthd1)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/olpfv.f90 0000644 0000000 0000000 00000000132 13543334734 014274 x ustar 00 30 mtime=1569569244.541642001
30 atime=1569569240.689644461
30 ctime=1569569244.541642001
elk-6.3.2/src/olpfv.f90 0000644 0025044 0025044 00000002152 13543334734 016343 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 olpfv(nmatp,ngp,igpig,apwalm,o)
use modmain
use modomp
implicit none
! arguments
integer, intent(in) :: nmatp,ngp,igpig(ngkmax)
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw,natmtot)
complex(8), intent(out) :: o(nmatp,nmatp)
! local variables
integer ias,i
integer nthd1,nthd2
! zero the upper triangular part of the matrix
do i=1,nmatp
o(1:i,i)=0.d0
end do
call holdthd(2,nthd1)
!$OMP PARALLEL SECTIONS DEFAULT(SHARED) &
!$OMP PRIVATE(ias) &
!$OMP NUM_THREADS(nthd1)
!$OMP SECTION
do ias=1,natmtot
call olpaa(tefvr,ias,ngp,apwalm(:,:,:,ias),nmatp,o)
end do
call olpistl(ngp,igpig,nmatp,o)
!$OMP SECTION
call holdthd(natmtot,nthd2)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd2)
do ias=1,natmtot
call olpalo(ias,ngp,apwalm(:,:,:,ias),nmatp,o)
call olplolo(ias,ngp,nmatp,o)
end do
!$OMP END PARALLEL DO
call freethd(nthd2)
!$OMP END PARALLEL SECTIONS
call freethd(nthd1)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/axangsu2.f90 0000644 0000000 0000000 00000000132 13543334734 014676 x ustar 00 30 mtime=1569569244.546641998
30 atime=1569569240.694644458
30 ctime=1569569244.546641998
elk-6.3.2/src/axangsu2.f90 0000644 0025044 0025044 00000002471 13543334734 016751 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007-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: axangsu2
subroutine axangsu2(v,th,su2)
! !INPUT/OUTPUT PARAMETERS:
! v : rotation axis vector (in,real(3))
! th : rotation angle (in,real)
! su2 : SU(2) representation of rotation (out,complex(2,2))
! !DESCRIPTION:
! Finds the complex ${\rm SU}(2)$ representation of a rotation defined by an
! axis vector $\hat{\bf v}$ and angle $\theta$. The spinor rotation matrix is
! given explicitly by
! $$ R^{1/2}(\hat{\bf v},\theta)=I\cos\frac{\theta}{2}
! -i(\hat{\bf v}\cdot\vec{\sigma})\sin\frac{\theta}{2}. $$
!
! !REVISION HISTORY:
! Created August 2007 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: v(3),th
complex(8), intent(out) :: su2(2,2)
! local variables
real(8) x,y,z,cs,sn,t1
x=v(1); y=v(2); z=v(3)
t1=sqrt(x**2+y**2+z**2)
if (t1.lt.1.d-8) then
write(*,*)
write(*,'("Error(axangsu2): zero length axis vector")')
write(*,*)
stop
end if
! normalise the vector
t1=1.d0/t1
x=x*t1; y=y*t1; z=z*t1
cs=cos(0.5d0*th)
sn=sin(0.5d0*th)
su2(1,1)=cmplx(cs,-z*sn,8)
su2(2,1)=cmplx(y*sn,-x*sn,8)
su2(1,2)=cmplx(-y*sn,-x*sn,8)
su2(2,2)=cmplx(cs,z*sn,8)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/checkmt.f90 0000644 0000000 0000000 00000000132 13543334734 014564 x ustar 00 30 mtime=1569569244.550641995
30 atime=1569569240.698644456
30 ctime=1569569244.550641995
elk-6.3.2/src/checkmt.f90 0000644 0025044 0025044 00000003252 13543334734 016635 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: checkmt
! !INTERFACE:
subroutine checkmt
! !USES:
use modmain
use modmpi
use modvars
! !DESCRIPTION:
! Checks for muffin-tins which are too close together or intersecting. If any
! such muffin-tins are found then the radii of their associated atomic species
! are adjusted so that the minimum distance between their surfaces is
! {\tt rmtdelta}.
!
! !REVISION HISTORY:
! Created May 2003 (JKD)
! Modified, October 2011 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,js
real(8) dmin,t1,t2
! automatic arrays
real(8) rmt0(nspecies)
rmt0(1:nspecies)=rmt(1:nspecies)
10 continue
! find the minimum distance between muffin-tin surfaces
call mtdmin(is,js,dmin)
! adjust muffin-tin radii if required
if (dmin.lt.rmtdelta-epslat) then
t1=rmt(is)+rmt(js)
t2=(t1+dmin-rmtdelta)/t1
rmt(is)=rmt(is)*t2
if (is.ne.js) rmt(js)=rmt(js)*t2
goto 10
end if
do is=1,nspecies
if (rmt(is).lt.0.25d0) then
write(*,*)
write(*,'("Error(checkmt): muffin-tin radius too small for species ",I4,&
&" (",A,")")') is,trim(spsymb(is))
write(*,'(" Radius : ",G18.10)') rmt(is)
write(*,*)
stop
end if
if (rmt(is).lt.rmt0(is)) then
if (mp_mpi) then
write(*,*)
write(*,'("Info(checkmt): reduced muffin-tin radius of species ",I3,&
&" (",A,") from ",F8.4," to ",F8.4)') is,trim(spsymb(is)),rmt0(is), &
rmt(is)
end if
end if
end do
! write to VARIABLES.OUT
call writevars('rmt',nv=nspecies,rva=rmt)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/symrf.f90 0000644 0000000 0000000 00000000132 13543334734 014306 x ustar 00 30 mtime=1569569244.555641992
30 atime=1569569240.704644452
30 ctime=1569569244.555641992
elk-6.3.2/src/symrf.f90 0000644 0025044 0025044 00000003312 13543334734 016354 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: symrf
! !INTERFACE:
subroutine symrf(nr,nri,np,ld,rfmt,rfir)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! nr : number of radial points for each species (in,integer(nspecies))
! nri : number of radial points on the inner part (in,integer(nspecies))
! np : total number of points in each muffin-tin (in,integer(nspecies))
! ld : leading dimension (in,integer)
! rfmt : real muffin-tin function (inout,real(ld,natmtot))
! rfir : real intersitial function (inout,real(ngtot))
! !DESCRIPTION:
! Symmetrises a real scalar function defined over the entire unit cell using
! the full set of crystal symmetries. In the muffin-tin of a particular atom
! the spherical harmonic coefficients of every equivlent atom are rotated and
! averaged. The interstitial part of the function is first Fourier transformed
! to $G$-space, and then averaged over each symmetry by rotating the Fourier
! coefficients and multiplying them by a phase factor corresponding to the
! symmetry translation.
!
! !REVISION HISTORY:
! Created May 2007 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nr(nspecies),nri(nspecies),np(nspecies)
integer, intent(in) :: ld
real(8), intent(inout) :: rfmt(ld,natmtot),rfir(ngtot)
! local variables
integer nthd
call holdthd(2,nthd)
!$OMP PARALLEL SECTIONS DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP SECTION
call symrfmt(nr,nri,np,ld,rfmt)
!$OMP SECTION
call symrfir(rfir)
!$OMP END PARALLEL SECTIONS
call freethd(nthd)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/z2mm.f90 0000644 0000000 0000000 00000000130 13543334734 014031 x ustar 00 29 mtime=1569569244.55964199
30 atime=1569569240.709644449
29 ctime=1569569244.55964199
elk-6.3.2/src/z2mm.f90 0000644 0025044 0025044 00000001562 13543334734 016106 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 Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: z2mm
! !INTERFACE:
pure subroutine z2mm(a,b,c)
! !INPUT/OUTPUT PARAMETERS:
! a : input matrix 1 (in,complex(2,2))
! b : input matrix 2 (in,complex(2,2))
! c : output matrix (out,complex(2,2))
! !DESCRIPTION:
! Multiplies two complex $2\times 2$ matrices. Note that the output matrix
! cannot be one of the input matrices.
!
! !REVISION HISTORY:
! Created October 2007 (JKD)
!EOP
!BOC
implicit none
! arguments
complex(8), intent(in) :: a(2,2),b(2,2)
complex(8), intent(out) :: c(2,2)
c(1,1)=a(1,1)*b(1,1)+a(1,2)*b(2,1)
c(2,1)=a(2,1)*b(1,1)+a(2,2)*b(2,1)
c(1,2)=a(1,1)*b(1,2)+a(1,2)*b(2,2)
c(2,2)=a(2,1)*b(1,2)+a(2,2)*b(2,2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/z2mctm.f90 0000644 0000000 0000000 00000000132 13543334734 014362 x ustar 00 30 mtime=1569569244.563641987
30 atime=1569569240.715644445
30 ctime=1569569244.563641987
elk-6.3.2/src/z2mctm.f90 0000644 0025044 0025044 00000001724 13543334734 016435 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 Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: z2mctm
! !INTERFACE:
pure subroutine z2mctm(a,b,c)
! !INPUT/OUTPUT PARAMETERS:
! a : input matrix 1 (in,complex(2,2))
! b : input matrix 2 (in,complex(2,2))
! c : output matrix (out,complex(2,2))
! !DESCRIPTION:
! Multiplies the conjugate transpose of one complex $2\times 2$ matrix with
! another. Note that the output matrix cannot be one of the input matrices.
!
! !REVISION HISTORY:
! Created October 2007 (JKD)
!EOP
!BOC
implicit none
! arguments
complex(8), intent(in) :: a(2,2),b(2,2)
complex(8), intent(out) :: c(2,2)
c(1,1)=conjg(a(1,1))*b(1,1)+conjg(a(2,1))*b(2,1)
c(2,1)=conjg(a(1,2))*b(1,1)+conjg(a(2,2))*b(2,1)
c(1,2)=conjg(a(1,1))*b(1,2)+conjg(a(2,1))*b(2,2)
c(2,2)=conjg(a(1,2))*b(1,2)+conjg(a(2,2))*b(2,2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/z2mmct.f90 0000644 0000000 0000000 00000000132 13543334734 014362 x ustar 00 30 mtime=1569569244.567641984
30 atime=1569569240.720644442
30 ctime=1569569244.567641984
elk-6.3.2/src/z2mmct.f90 0000644 0025044 0025044 00000001712 13543334734 016432 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 Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: z2mmct
! !INTERFACE:
pure subroutine z2mmct(a,b,c)
! !INPUT/OUTPUT PARAMETERS:
! a : input matrix 1 (in,complex(2,2))
! b : input matrix 2 (in,complex(2,2))
! c : output matrix (out,complex(2,2))
! !DESCRIPTION:
! Multiplies a $2\times 2$ matrix with the conjugate transpose of another.
! Note that the output matrix cannot be one of the input matrices.
!
! !REVISION HISTORY:
! Created October 2007 (JKD)
!EOP
!BOC
implicit none
! arguments
complex(8), intent(in) :: a(2,2),b(2,2)
complex(8), intent(out) :: c(2,2)
c(1,1)=a(1,1)*conjg(b(1,1))+a(1,2)*conjg(b(1,2))
c(2,1)=a(2,1)*conjg(b(1,1))+a(2,2)*conjg(b(1,2))
c(1,2)=a(1,1)*conjg(b(2,1))+a(1,2)*conjg(b(2,2))
c(2,2)=a(2,1)*conjg(b(2,1))+a(2,2)*conjg(b(2,2))
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/writefermi.f90 0000644 0000000 0000000 00000000132 13543334734 015323 x ustar 00 30 mtime=1569569244.571641982
30 atime=1569569240.726644438
30 ctime=1569569244.571641982
elk-6.3.2/src/writefermi.f90 0000644 0025044 0025044 00000001052 13543334734 017370 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: writefermi
! !INTERFACE:
subroutine writefermi
! !USES:
use modmain
! !DESCRIPTION:
! Writes the Fermi energy to the file {\tt EFERMI.OUT}.
!
! !REVISION HISTORY:
! Created March 2005 (JKD)
!EOP
!BOC
implicit none
open(50,file='EFERMI'//trim(filext),form='FORMATTED')
write(50,'(G18.10)') efermi
close(50)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/findnjcmax.f90 0000644 0000000 0000000 00000000132 13543334734 015267 x ustar 00 30 mtime=1569569244.576641979
30 atime=1569569240.730644435
30 ctime=1569569244.576641979
elk-6.3.2/src/findnjcmax.f90 0000644 0025044 0025044 00000000754 13543334734 017344 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 findnjcmax
use modmain
implicit none
! local variables
integer is,n
! find the maximum size of the spherical Bessel function array over all species
njcmax=1
do is=1,nspecies
n=(lmaxi+1)*nrcmti(is)+(lmaxo+1)*(nrcmt(is)-nrcmti(is))
if (n.gt.njcmax) njcmax=n
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/findscq.f90 0000644 0000000 0000000 00000000132 13543334734 014575 x ustar 00 30 mtime=1569569244.580641976
30 atime=1569569240.735644432
30 ctime=1569569244.580641976
elk-6.3.2/src/findscq.f90 0000644 0025044 0025044 00000007053 13543334734 016651 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 findscq(iq,avec0,nsc,vsc)
use modmain
use modphonon
implicit none
! arguments
integer, intent(in) :: iq
real(8), intent(in) :: avec0(3,3)
integer, intent(out) :: nsc
real(8), intent(out) :: vsc(3,nqptnr)
! local variables
integer i1,i2,i3
integer scl(3,3),i,n
real(8) dmin,t1
real(8) v1(3),v2(3)
! check for Gamma-point phonon
if (tphq0) then
scl(:,:)=0
scl(1,1)=1
scl(2,2)=1
scl(3,3)=1
nsc=1
goto 10
end if
! find the first lattice vector
dmin=1.d8
do i1=-ngridq(1),ngridq(1)
do i2=-ngridq(2),ngridq(2)
do i3=-ngridq(3),ngridq(3)
t1=dble(i1)*vql(1,iq)+dble(i2)*vql(2,iq)+dble(i3)*vql(3,iq)
if (abs(t1-nint(t1)).lt.epslat) then
v1(:)=dble(i1)*avec0(:,1)+dble(i2)*avec0(:,2)+dble(i3)*avec0(:,3)
t1=sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
if ((t1.lt.dmin).and.(t1.gt.epslat)) then
scl(1,1)=i1
scl(2,1)=i2
scl(3,1)=i3
dmin=t1
end if
end if
end do
end do
end do
! find the second lattice vector
dmin=1.d8
do i1=-ngridq(1),ngridq(1)
do i2=-ngridq(2),ngridq(2)
do i3=-ngridq(3),ngridq(3)
t1=dble(i1)*vql(1,iq)+dble(i2)*vql(2,iq)+dble(i3)*vql(3,iq)
if (abs(t1-nint(t1)).lt.epslat) then
! area defined by first two lattice vectors
n=(i2*scl(3,1)-i3*scl(2,1))**2 &
+(i3*scl(1,1)-i1*scl(3,1))**2 &
+(i1*scl(2,1)-i2*scl(1,1))**2
if (n.ne.0) then
v1(:)=dble(i1)*avec0(:,1)+dble(i2)*avec0(:,2)+dble(i3)*avec0(:,3)
t1=v1(1)**2+v1(2)**2+v1(3)**2
if (t1.lt.dmin) then
scl(1,2)=i1
scl(2,2)=i2
scl(3,2)=i3
dmin=t1
end if
end if
end if
end do
end do
end do
! find the third lattice vector
nsc=0
dmin=1.d8
do i1=-ngridq(1),ngridq(1)
do i2=-ngridq(2),ngridq(2)
do i3=-ngridq(3),ngridq(3)
t1=dble(i1)*vql(1,iq)+dble(i2)*vql(2,iq)+dble(i3)*vql(3,iq)
if (abs(t1-nint(t1)).lt.epslat) then
! number of primitive unit cells in supercell
n=scl(1,2)*(i2*scl(3,1)-i3*scl(2,1)) &
+scl(2,2)*(i3*scl(1,1)-i1*scl(3,1)) &
+scl(3,2)*(i1*scl(2,1)-i2*scl(1,1))
if (n.ne.0) then
v1(:)=dble(i1)*avec0(:,1)+dble(i2)*avec0(:,2)+dble(i3)*avec0(:,3)
t1=v1(1)**2+v1(2)**2+v1(3)**2
if (t1.lt.dmin) then
nsc=abs(n)
scl(1,3)=i1
scl(2,3)=i2
scl(3,3)=i3
dmin=t1
end if
end if
end if
end do
end do
end do
if (nsc.eq.0) goto 30
10 continue
! new lattice vectors
do i=1,3
avec(:,i)=dble(scl(1,i))*avec0(:,1) &
+dble(scl(2,i))*avec0(:,2) &
+dble(scl(3,i))*avec0(:,3)
end do
! inverse of lattice vector matrix
call r3minv(avec,ainv)
! generate offset vectors for each primitive cell in the supercell
n=1
vsc(:,1)=0.d0
do i1=-ngridq(1),ngridq(1)
do i2=-ngridq(2),ngridq(2)
do i3=-ngridq(3),ngridq(3)
if (n.eq.nsc) return
v1(:)=dble(i1)*avec0(:,1)+dble(i2)*avec0(:,2)+dble(i3)*avec0(:,3)
call r3mv(ainv,v1,v2)
call r3frac(epslat,v2)
call r3mv(avec,v2,v1)
do i=1,n
t1=abs(v1(1)-vsc(1,i))+abs(v1(2)-vsc(2,i))+abs(v1(3)-vsc(3,i))
if (t1.lt.epslat) goto 20
end do
n=n+1
vsc(:,n)=v1(:)
20 continue
end do
end do
end do
30 continue
write(*,*)
write(*,'("Error(findscq): unable to generate supercell")')
write(*,*)
stop
end subroutine
elk-6.3.2/src/PaxHeaders.21352/plot1d.f90 0000644 0000000 0000000 00000000132 13543334734 014351 x ustar 00 30 mtime=1569569244.584641974
30 atime=1569569240.740644429
30 ctime=1569569244.584641974
elk-6.3.2/src/plot1d.f90 0000644 0025044 0025044 00000003533 13543334734 016424 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: plot1d
! !INTERFACE:
subroutine plot1d(fnum1,fnum2,nf,rfmt,rfir)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! fnum1 : plot file number (in,integer)
! fnum2 : vertex location file number (in,integer)
! nf : number of functions (in,integer)
! rfmt : real muffin-tin function (in,real(npmtmax,natmtot,nf))
! rfir : real intersitial function (in,real(ngtot,nf))
! !DESCRIPTION:
! Produces a 1D plot of the real functions contained in arrays {\tt rfmt} and
! {\tt rfir} along the lines connecting the vertices in the global array
! {\tt vvlp1d}. See routine {\tt rfplot}.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: fnum1,fnum2,nf
real(8), intent(in) :: rfmt(npmtmax,natmtot,nf),rfir(ngtot,nf)
! local variables
integer jf,ip,iv
real(8) fmin,fmax,t1
! allocatable arrays
real(8), allocatable :: fp(:,:)
if ((nf.lt.1).or.(nf.gt.4)) then
write(*,*)
write(*,'("Error(plot1d): invalid number of functions : ",I8)') nf
write(*,*)
stop
end if
allocate(fp(npp1d,nf))
! connect the 1D plotting vertices
call plotpt1d(avec,nvp1d,npp1d,vvlp1d,vplp1d,dvp1d,dpp1d)
do jf=1,nf
! evaluate function at each point
call rfplot(npp1d,vplp1d,rfmt(:,:,jf),rfir(:,jf),fp(:,jf))
end do
do ip=1,npp1d
! write the point distances and function to file
write(fnum1,'(5G18.10)') dpp1d(ip),(fp(ip,jf),jf=1,nf)
end do
! write the vertex location lines
fmin=minval(fp(:,:))
fmax=maxval(fp(:,:))
t1=0.5d0*(fmax-fmin)
do iv=1,nvp1d
write(fnum2,'(2G18.10)') dvp1d(iv),fmax+t1
write(fnum2,'(2G18.10)') dvp1d(iv),fmin-t1
write(fnum2,'(" ")')
end do
deallocate(fp)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/plot2d.f90 0000644 0000000 0000000 00000000130 13543334734 014350 x ustar 00 29 mtime=1569569244.58964197
30 atime=1569569240.745644426
29 ctime=1569569244.58964197
elk-6.3.2/src/plot2d.f90 0000644 0025044 0025044 00000003704 13543334734 016425 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: plot2d
! !INTERFACE:
subroutine plot2d(tproj,fnum,nf,rfmt,rfir)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! tproj : .true. if nf=3 and the vector function should be projected onto the
! 2D plotting plane axes (in,logical)
! fnum : plot file number (in,integer)
! nf : number of functions (in,integer)
! rfmt : real muffin-tin function (in,real(npmtmax,natmtot,nf))
! rfir : real intersitial function (in,real(ngtot,nf))
! !DESCRIPTION:
! Produces a 2D plot of the real functions contained in arrays {\tt rfmt} and
! {\tt rfir} on the parallelogram defined by the corner vertices in the global
! array {\tt vclp2d}. See routine {\tt rfplot}.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
logical, intent(in) :: tproj
integer, intent(in) :: fnum,nf
real(8), intent(in) :: rfmt(npmtmax,natmtot,nf),rfir(ngtot,nf)
! local variables
integer np,jf,ip
real(8) vpnl(3)
! allocatable arrays
real(8), allocatable :: vpl(:,:),vppc(:,:),fp(:,:)
if ((nf.lt.1).or.(nf.gt.4)) then
write(*,*)
write(*,'("Error(plot2d): invalid number of functions : ",I8)') nf
write(*,*)
stop
end if
! allocate local arrays
np=np2d(1)*np2d(2)
allocate(vpl(3,np),vppc(2,np),fp(np,nf))
! generate the 2D plotting points
call plotpt2d(avec,ainv,vpnl,vpl,vppc)
! evaluate the functions at the grid points
do jf=1,nf
call rfplot(np,vpl,rfmt(:,:,jf),rfir(:,jf),fp(:,jf))
end do
! project the vector function onto the 2D plotting plane axes if required
if (tproj.and.(nf.eq.3)) then
call proj2d(np,fp)
end if
! write the functions to file
write(fnum,'(2I6," : grid size")') np2d(:)
do ip=1,np
write(fnum,'(6G18.10)') vppc(1,ip),vppc(2,ip),(fp(ip,jf),jf=1,nf)
end do
deallocate(vpl,vppc,fp)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/plot3d.f90 0000644 0000000 0000000 00000000132 13543334734 014353 x ustar 00 30 mtime=1569569244.593641968
30 atime=1569569240.750644422
30 ctime=1569569244.593641968
elk-6.3.2/src/plot3d.f90 0000644 0025044 0025044 00000003340 13543334734 016422 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-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: plot3d
! !INTERFACE:
subroutine plot3d(fnum,nf,rfmt,rfir)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! fnum : plot file number (in,integer)
! nf : number of functions (in,integer)
! rfmt : real muffin-tin function (in,real(npmtmax,natmtot,nf))
! rfir : real intersitial function (in,real(ngtot,nf))
! !DESCRIPTION:
! Produces a 3D plot of the real functions contained in arrays {\tt rfmt} and
! {\tt rfir} in the parallelepiped defined by the corner vertices in the
! global array {\tt vclp3d}. See routine {\tt rfarray}.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
! Modified, October 2008 (F. Bultmark, F. Cricchio, L. Nordstrom)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: fnum,nf
real(8), intent(in) :: rfmt(npmtmax,natmtot,nf),rfir(ngtot,nf)
! local variables
integer np,jf,ip
real(8) v1(3)
! allocatable arrays
real(8), allocatable :: vpl(:,:),fp(:,:)
if ((nf.lt.1).or.(nf.gt.4)) then
write(*,*)
write(*,'("Error(plot3d): invalid number of functions : ",I8)') nf
write(*,*)
stop
end if
! total number of plot points
np=np3d(1)*np3d(2)*np3d(3)
! allocate local arrays
allocate(vpl(3,np),fp(np,nf))
! generate the 3D plotting points
call plotpt3d(vpl)
! evaluate the functions at the grid points
do jf=1,nf
call rfplot(np,vpl,rfmt(:,:,jf),rfir(:,jf),fp(:,jf))
end do
! write functions to file
write(fnum,'(3I6," : grid size")') np3d(:)
do ip=1,np
call r3mv(avec,vpl(:,ip),v1)
write(fnum,'(7G18.10)') v1(:),(fp(ip,jf),jf=1,nf)
end do
deallocate(vpl,fp)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/hmllolo.f90 0000644 0000000 0000000 00000000131 13543334734 014613 x ustar 00 30 mtime=1569569244.597641965
29 atime=1569569240.75464442
30 ctime=1569569244.597641965
elk-6.3.2/src/hmllolo.f90 0000644 0025044 0025044 00000002067 13543334734 016670 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 hmllolo(ias,ngp,ld,h)
use modmain
implicit none
! arguments
integer, intent(in) :: ias,ngp,ld
complex(8), intent(inout) :: h(ld,*)
! local variables
integer is,ilo,jlo
integer l1,l2,l3,m1,m2,m3
integer lm1,lm2,lm3,i,j
complex(8) z1
is=idxis(ias)
do jlo=1,nlorb(is)
l3=lorbl(jlo,is)
do m3=-l3,l3
lm3=idxlm(l3,m3)
j=ngp+idxlo(lm3,jlo,ias)
do ilo=1,nlorb(is)
l1=lorbl(ilo,is)
do m1=-l1,l1
lm1=idxlm(l1,m1)
i=ngp+idxlo(lm1,ilo,ias)
if (i.le.j) then
z1=0.d0
do l2=0,lmaxo
if (mod(l1+l2+l3,2).eq.0) then
do m2=-l2,l2
lm2=idxlm(l2,m2)
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 if
end do
end do
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/olprad.f90 0000644 0000000 0000000 00000000132 13543334734 014427 x ustar 00 30 mtime=1569569244.602641962
30 atime=1569569240.759644417
30 ctime=1569569244.602641962
elk-6.3.2/src/olprad.f90 0000644 0025044 0025044 00000003437 13543334734 016505 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: olprad
! !INTERFACE:
subroutine olprad
! !USES:
use modmain
! !DESCRIPTION:
! Calculates the radial overlap integrals of the APW and local-orbital basis
! functions. In other words, for atom $\alpha$, it computes integrals of the
! form
! $$ o^{\alpha}_{qp}=\int_0^{R_i}u^{\alpha}_{q;l_p}(r)v^{\alpha}_p(r)r^2dr $$
! and
! $$ o^{\alpha}_{pp'}=\int_0^{R_i}v^{\alpha}_p(r)v^{\alpha}_{p'}(r)r^2dr,
! \quad l_p=l_{p'} $$
! where $u^{\alpha}_{q;l}$ is the $q$th APW radial function for angular
! momentum $l$; and $v^{\alpha}_p$ is the $p$th local-orbital radial function
! and has angular momentum $l_p$.
!
! !REVISION HISTORY:
! Created November 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ias,nr
integer ilo,jlo,l,io
! automatic arrays
real(8) fr(nrmtmax)
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
!-------------------------------------!
! APW-local-orbital integrals !
!-------------------------------------!
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do io=1,apword(l,is)
fr(1:nr)=apwfr(1:nr,1,io,l,ias)*lofr(1:nr,1,ilo,ias)
oalo(io,ilo,ias)=dot_product(wrmt(1:nr,is),fr(1:nr))
end do
end do
!-----------------------------------------------!
! local-orbital-local-orbital integrals !
!-----------------------------------------------!
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do jlo=1,nlorb(is)
if (lorbl(jlo,is).eq.l) then
fr(1:nr)=lofr(1:nr,1,ilo,ias)*lofr(1:nr,1,jlo,ias)
ololo(ilo,jlo,ias)=dot_product(wrmt(1:nr,is),fr(1:nr))
end if
end do
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/occupy.f90 0000644 0000000 0000000 00000000130 13543334734 014446 x ustar 00 29 mtime=1569569244.60664196
30 atime=1569569240.764644414
29 ctime=1569569244.60664196
elk-6.3.2/src/occupy.f90 0000644 0025044 0025044 00000006335 13543334734 016526 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: occupy
! !INTERFACE:
subroutine occupy
! !USES:
use modmain
use modtest
! !DESCRIPTION:
! Finds the Fermi energy and sets the occupation numbers for the
! second-variational states using the routine {\tt fermi}.
!
! !REVISION HISTORY:
! Created February 2004 (JKD)
! Added gap estimation, November 2009 (F. Cricchio)
! Added adaptive smearing width, April 2010 (T. Bjorkman)
!EOP
!BOC
implicit none
! local variables
integer, parameter :: maxit=1000
integer ik,ist,it
real(8) e0,e1,e
real(8) chg,x,t1
! external functions
real(8) sdelta,stheta
external sdelta,stheta
! determine the smearing width automatically if required
if ((autoswidth).and.(iscl.gt.1)) call findswidth
! find minimum and maximum eigenvalues
e0=evalsv(1,1)
e1=e0
do ik=1,nkpt
do ist=1,nstsv
e=evalsv(ist,ik)
if (e.lt.e0) e0=e
if (e.gt.e1) e1=e
end do
end do
if (e0.lt.e0min) then
write(*,*)
write(*,'("Warning(occupy): minimum eigenvalue less than minimum &
&linearisation energy : ",2G18.10)') e0,e0min
write(*,'(" for s.c. loop ",I5)') iscl
end if
t1=1.d0/swidth
! determine the Fermi energy using the bisection method
do it=1,maxit
efermi=0.5d0*(e0+e1)
chg=0.d0
do ik=1,nkpt
do ist=1,nstsv
e=evalsv(ist,ik)
if (e.lt.e0min) then
occsv(ist,ik)=0.d0
else
x=(efermi-e)*t1
occsv(ist,ik)=occmax*stheta(stype,x)
chg=chg+wkpt(ik)*occsv(ist,ik)
end if
end do
end do
if (chg.lt.chgval) then
e0=efermi
else
e1=efermi
end if
if ((e1-e0).lt.1.d-12) goto 10
end do
write(*,*)
write(*,'("Warning(occupy): could not find Fermi energy")')
10 continue
! find the density of states at the Fermi surface in units of
! states/Hartree/unit cell
fermidos=0.d0
do ik=1,nkpt
do ist=1,nstsv
x=(evalsv(ist,ik)-efermi)*t1
fermidos=fermidos+wkpt(ik)*sdelta(stype,x)*t1
end do
if (abs(occsv(nstsv,ik)).gt.epsocc) then
write(*,*)
write(*,'("Warning(occupy): not enough empty states for k-point ",I6)') ik
write(*,'(" and s.c. loop ",I5)') iscl
end if
end do
fermidos=fermidos*occmax
! write Fermi density of states to test file
call writetest(500,'DOS at Fermi energy',tol=5.d-3,rv=fermidos)
! estimate the indirect band gap (FC)
e0=-1.d8
e1=1.d8
ikgap(1)=1
ikgap(2)=1
! these loops are incorrectly ordered to fix a bug in versions 17 and 18 of the
! Intel compiler
do ist=1,nstsv
do ik=1,nkpt
e=evalsv(ist,ik)
if (e.lt.efermi) then
if (e.gt.e0) then
e0=e
ikgap(1)=ik
end if
else
if (e.lt.e1) then
e1=e
ikgap(2)=ik
end if
end if
end do
end do
bandgap(1)=e1-e0
! write band gap to test file
call writetest(510,'estimated indirect band gap',tol=2.d-2,rv=bandgap(1))
! estimate the direct band gap
e=1.d8
ikgap(3)=1
do ik=1,nkpt
e0=-1.d8
e1=1.d8
do ist=1,nstsv
t1=evalsv(ist,ik)
if (t1.le.efermi) then
if (t1.gt.e0) e0=t1
else
if (t1.lt.e1) e1=t1
end if
end do
t1=e1-e0
if (t1.lt.e) then
e=t1
ikgap(3)=ik
end if
end do
bandgap(2)=e
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/findkpt.f90 0000644 0000000 0000000 00000000131 13543334734 014604 x ustar 00 30 mtime=1569569244.611641956
29 atime=1569569240.76964441
30 ctime=1569569244.611641956
elk-6.3.2/src/findkpt.f90 0000644 0025044 0025044 00000002075 13543334734 016660 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 findkpt(vpl,isym,ik)
use modmain
implicit none
! arguments
real(8), intent(in) :: vpl(3)
integer, intent(out) :: isym,ik
! local variables
integer ivp(3),lspl
real(8) v1(3),v2(3),t1
v1(:)=vpl(:)-vkloff(:)/dble(ngridk(:))
ivp(:)=nint(v1(:)*ngridk(:))
ivp(:)=modulo(ivp(:),ngridk(:))
ik=ivkik(ivp(1),ivp(2),ivp(3))
v1(:)=vkl(:,ik)
call r3frac(epslat,v1)
! find the symmetry which rotates vkl to vpl
do isym=1,nsymcrys
lspl=lsplsymc(isym)
! multiply vpl by the transpose of the symmetry matrix (i.e. the inverse)
v2(:)=symlat(1,:,lspl)*vpl(1) &
+symlat(2,:,lspl)*vpl(2) &
+symlat(3,:,lspl)*vpl(3)
call r3frac(epslat,v2)
t1=abs(v1(1)-v2(1))+abs(v1(2)-v2(2))+abs(v1(3)-v2(3))
if (t1.lt.epslat) return
end do
write(*,*)
write(*,'("Error(findkpt): equivalent k-point not in set")')
write(*,'(" Requested k-point : ",3G18.10)') vpl
write(*,*)
stop
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zfmtint.f90 0000644 0000000 0000000 00000000132 13543334734 014641 x ustar 00 30 mtime=1569569244.615641954
30 atime=1569569240.775644406
30 ctime=1569569244.615641954
elk-6.3.2/src/zfmtint.f90 0000644 0025044 0025044 00000001362 13543334734 016712 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.
complex(8) function zfmtint(nr,nri,wr,zfmt)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: wr(nr)
complex(8), intent(in) :: zfmt(*)
! local variables
integer ir,i
complex(8) z1
! automatic arrays
real(8) fr1(nr),fr2(nr)
i=1
do ir=1,nri
z1=zfmt(i)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+lmmaxi
end do
do ir=nri+1,nr
z1=zfmt(i)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+lmmaxo
end do
! integrate over r
z1=cmplx(dot_product(wr(:),fr1(:)),dot_product(wr(:),fr2(:)),8)
zfmtint=fourpi*y00*z1
return
end function
elk-6.3.2/src/PaxHeaders.21352/rotrfmt.f90 0000644 0000000 0000000 00000000132 13543334734 014643 x ustar 00 30 mtime=1569569244.619641951
30 atime=1569569240.780644403
30 ctime=1569569244.619641951
elk-6.3.2/src/rotrfmt.f90 0000644 0025044 0025044 00000001172 13543334734 016713 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.
subroutine rotrfmt(rot,nr,nri,rfmt1,rfmt2)
use modmain
implicit none
! arguments
real(8), intent(in) :: rot(3,3)
integer, intent(in) :: nr,nri
real(8), intent(in) :: rfmt1(*)
real(8), intent(out) :: rfmt2(*)
! local variables
integer nro,i
! inner part of muffin-tin
call rotrflm(rot,lmaxi,nri,lmmaxi,rfmt1,rfmt2)
! outer part of muffin-tin
nro=nr-nri
i=lmmaxi*nri+1
call rotrflm(rot,lmaxo,nro,lmmaxo,rfmt1(i),rfmt2(i))
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/forcek.f90 0000644 0000000 0000000 00000000130 13543334734 014415 x ustar 00 30 mtime=1569569244.624641948
28 atime=1569569240.7856444
30 ctime=1569569244.624641948
elk-6.3.2/src/forcek.f90 0000644 0025044 0025044 00000011360 13543334734 016467 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.
!BOP
! !ROUTINE: forcek
! !INTERFACE:
subroutine forcek(ik)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! ik : reduced k-point number (in,integer)
! !DESCRIPTION:
! Computes the {\bf k}-dependent contribution to the incomplete basis set
! (IBS) force. See the calling routine {\tt force} for a full description.
!
! !REVISION HISTORY:
! Created June 2006 (JKD)
! Updated for spin-spiral case, May 2007 (Francesco Cricchio and JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ik
! local variables
integer ispn0,ispn1,ispn,jspn
integer n,nm,nm2,is,ias,ist,jst
integer iv(3),jv(3),ig,i,j,k,l
real(8) vj(3),sum,t1
complex(8) z1,z2
! allocatable arrays
integer, allocatable :: ijg(:)
real(8), allocatable :: dp(:),evalfv(:,:)
complex(8), allocatable :: apwalm(:,:,:,:)
complex(8), allocatable :: evecfv(:,:,:),evecsv(:,:)
complex(8), allocatable :: h(:),o(:),dlh(:),dlo(:)
complex(8), allocatable :: vh(:),vo(:),ffv(:,:),y(:)
! external functions
complex(8) zdotc
external zdotc
nm2=nmatmax**2
! allocate local arrays
allocate(ijg(nm2),dp(nm2))
allocate(evalfv(nstfv,nspnfv))
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot))
allocate(evecfv(nmatmax,nstfv,nspnfv))
allocate(h(nm2),o(nm2),dlh(nm2),dlo(nm2))
allocate(vh(nmatmax),vo(nmatmax))
allocate(ffv(nstfv,nstfv),y(nstfv))
! get the eigenvalues/vectors from file
call getevalfv(filext,ik,vkl(:,ik),evalfv)
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
if (tevecsv) then
allocate(evecsv(nstsv,nstsv))
call getevecsv(filext,ik,vkl(:,ik),evecsv)
end if
! loop over first-variational spin components
do jspn=1,nspnfv
if (spinsprl) then
ispn0=jspn; ispn1=jspn
else
ispn0=1; ispn1=nspinor
end if
n=ngk(jspn,ik)
nm=nmat(jspn,ik)
do j=1,n
k=(j-1)*nm
jv(:)=ivg(:,igkig(j,jspn,ik))
vj(:)=0.5d0*vgkc(:,j,jspn,ik)
do i=1,j
k=k+1
iv(:)=ivg(:,igkig(i,jspn,ik))-jv(:)
ijg(k)=ivgig(iv(1),iv(2),iv(3))
dp(k)=dot_product(vgkc(:,i,jspn,ik),vj(:))
end do
end do
! find the matching coefficients
call match(n,vgkc(:,:,jspn,ik),gkc(:,jspn,ik),sfacgk(:,:,jspn,ik),apwalm)
! loop over species and atoms
do ias=1,natmtot
is=idxis(ias)
! Hamiltonian and overlap matrices
h(:)=0.d0
call hmlaa(.false.,ias,n,apwalm(:,:,:,ias),nm,h)
call hmlalo(ias,n,apwalm(:,:,:,ias),nm,h)
o(:)=0.d0
call olpaa(.false.,ias,n,apwalm(:,:,:,ias),nm,o)
call olpalo(ias,n,apwalm(:,:,:,ias),nm,o)
! loop over Cartesian directions
do l=1,3
! APW-APW contribution
do j=1,n
k=(j-1)*nm
do i=1,j
k=k+1
ig=ijg(k)
t1=vgc(l,ig)
z1=-ffacg(ig,is)*conjg(sfacg(ig,ias))
z2=t1*(dp(k)*z1+h(k))
dlh(k)=cmplx(-aimag(z2),dble(z2),8)
z2=t1*(z1+o(k))
dlo(k)=cmplx(-aimag(z2),dble(z2),8)
end do
end do
do j=n+1,nm
k=(j-1)*nm
! APW-local-orbital contribution
do i=1,n
k=k+1
t1=vgkc(l,i,jspn,ik)
z1=t1*h(k)
dlh(k)=cmplx(-aimag(z1),dble(z1),8)
z1=t1*o(k)
dlo(k)=cmplx(-aimag(z1),dble(z1),8)
end do
! zero the local-orbital-local-orbital contribution
do i=n+1,j
k=k+1
dlh(k)=0.d0
dlo(k)=0.d0
end do
end do
! compute the force matrix elements in the first-variational basis
do jst=1,nstfv
call zhemv('U',nm,zone,dlh,nm,evecfv(:,jst,jspn),1,zzero,vh,1)
call zhemv('U',nm,zone,dlo,nm,evecfv(:,jst,jspn),1,zzero,vo,1)
t1=evalfv(jst,jspn)
do ist=1,nstfv
z1=zdotc(nm,evecfv(:,ist,jspn),1,vh,1)
z2=zdotc(nm,evecfv(:,ist,jspn),1,vo,1)
ffv(ist,jst)=z1-t1*z2
end do
end do
! compute the force using the second-variational coefficients if required
sum=0.d0
if (tevecsv) then
! spin-polarised case
do j=1,nstsv
do ispn=ispn0,ispn1
i=(ispn-1)*nstfv+1
call zgemv('N',nstfv,nstfv,zone,ffv,nstfv,evecsv(i,j),1,zzero,y,1)
z1=zdotc(nstfv,evecsv(i,j),1,y,1)
sum=sum+occsv(j,ik)*dble(z1)
end do
end do
else
! spin-unpolarised case
do j=1,nstsv
sum=sum+occsv(j,ik)*dble(ffv(j,j))
end do
end if
!$OMP CRITICAL(forcek_)
forceibs(l,ias)=forceibs(l,ias)+wkpt(ik)*sum
!$OMP END CRITICAL(forcek_)
! end loop over Cartesian components
end do
! end loop over atoms and species
end do
! end loop over first-variational spins
end do
deallocate(ijg,dp,evalfv,apwalm,evecfv)
if (tevecsv) deallocate(evecsv)
deallocate(h,o,dlh,dlo,vh,vo,ffv,y)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/eveqnfvr.f90 0000644 0000000 0000000 00000000132 13543334734 015002 x ustar 00 30 mtime=1569569244.629641945
30 atime=1569569240.790644397
30 ctime=1569569244.629641945
elk-6.3.2/src/eveqnfvr.f90 0000644 0025044 0025044 00000017201 13543334734 017052 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.
!BOP
! !ROUTINE: eveqnfvr
! !INTERFACE:
subroutine eveqnfvr(nmatp,ngp,vpc,h,o,evalfv,evecfv)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! nmatp : order of overlap and Hamiltonian matrices (in,integer)
! ngp : number of G+p-vectors (in,integer)
! vpc : p-vector in Cartesian coordinates (in,real(3))
! h,o : Hamiltonian and overlap matrices in packed or upper triangular
! form (in,complex(*))
! evalfv : first-variational eigenvalues (out,real(nstfv))
! evecfv : first-variational eigenvectors (out,complex(nmatmax,nstfv))
! !DESCRIPTION:
! This routine solves the first-variational eigenvalue equation for the
! special case when inversion symmetry is present. In this case the
! Hamiltonian and overlap matrices can be made real by using appropriate
! linear combinations of the local-orbitals for atoms related by inversion
! symmetry. These are derived from the effect of parity and complex
! conjugation on the spherical harmonics: $P Y_{lm}=(-1)^l Y_{lm}$ and
! $(Y_{lm})^*=(-1)^mY_{l-m}$.
!
! !REVISION HISTORY:
! Created May 2011 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nmatp,ngp
real(8), intent(in) :: vpc(3)
complex(8), intent(in) :: h(*),o(*)
real(8), intent(out) :: evalfv(nstfv)
complex(8), intent(out) :: evecfv(nmatmax,nstfv)
! local variables
integer is,ia,ja,jas
integer ilo,i,j,k,l,m
integer i1,i2,j1,j2
integer k1,k2,k3,k4
integer l1,l2,m1,m2
integer lwork,info,nthd
real(8) v(3),vl,vu
real(8) t1,t2,t3,t4
real(8) ts0,ts1
complex(8) h1,h2,o1,o2,z1
! allocatable arrays
logical, allocatable :: tr(:),tp(:)
integer, allocatable :: idx(:),s(:),map(:,:)
integer, allocatable :: iwork(:),ifail(:)
real(8), allocatable :: rh(:),ro(:),w(:)
real(8), allocatable :: rv(:,:),work(:)
complex(8), allocatable :: zp(:)
call timesec(ts0)
allocate(tr(nlotot),tp(nlotot))
allocate(idx(nlotot),s(nlotot))
allocate(map(nlotot,nlotot))
allocate(zp(nlotot))
tp(:)=.false.
i=0
do is=1,nspecies
do ia=1,natoms(is)
! symmetry equivalent atom, mapped with inversion
ja=ieqatom(ia,is,2)
jas=idxas(ja,is)
! residual phase factor
v(:)=atposc(:,ia,is)+atposc(:,ja,is)
t1=0.5d0*dot_product(vpc(:),v(:))
z1=cmplx(cos(t1),sin(t1),8)
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do m=-l,l
i=i+1
! index to conjugate local-orbital in symmetry equivalent atom
idx(i)=idxlo(idxlm(l,-m),ilo,jas)
if (ia.ne.ja) then
! sign of parity and conjugation operators
if (mod(l+m,2).eq.0) then
s(i)=1
else
s(i)=-1
end if
if (ia.lt.ja) then
! if ia < ja use the real part of the sum of matrix elements
tr(i)=.true.
else if (ia.gt.ja) then
! if ia > ja use the imaginary part of the difference of matrix elements
s(i)=-s(i)
tr(i)=.false.
end if
else
! if ia = ja then use real function when l even and imaginary when l is odd
if (mod(m,2).eq.0) then
s(i)=1
else
s(i)=-1
end if
! new function should be real if symmetric or imaginary if antisymmetric
if (mod(l,2).eq.0) then
! l even
if (m.ge.0) then
tr(i)=.true.
else
s(i)=-s(i)
tr(i)=.false.
end if
else
! l odd
if (m.ge.0) then
tr(i)=.false.
else
s(i)=-s(i)
tr(i)=.true.
end if
end if
end if
! phase factors if required
if (abs(t1).gt.1.d-8) then
zp(i)=z1
tp(i)=.true.
end if
end do
end do
end do
end do
! map from local-orbital indices to position in matrix
do m=1,nlotot
j=ngp+m
do l=1,m
i=ngp+l
map(l,m)=i+(j-1)*nmatp
map(m,l)=map(l,m)
end do
end do
!---------------------------------!
! real Hamiltonian matrix !
!---------------------------------!
allocate(rh(nmatp**2))
!
do j=1,ngp
k=(j-1)*nmatp+1
call dcopy(j,h(k),2,rh(k),1)
end do
!
do m1=1,nlotot
j1=ngp+m1
j2=ngp+idx(m1)
do i=1,ngp
k1=i+(j1-1)*nmatp
k2=i+(j2-1)*nmatp
h1=h(k1); h2=h(k2)
if (tp(m1)) then
h1=h1*zp(m1); h2=h2*zp(m1)
end if
if (tr(m1)) then
rh(k1)=dble(h1)+s(m1)*dble(h2)
else
rh(k1)=aimag(h1)+s(m1)*aimag(h2)
end if
end do
end do
!
do m1=1,nlotot
m2=idx(m1)
do l1=1,m1
l2=idx(l1)
k1=map(l1,m1); k2=map(l1,m2); k3=map(l2,m1); k4=map(l2,m2)
if ((tr(l1).and.tr(m1)).or.((.not.tr(l1)).and.(.not.tr(m1)))) then
rh(k1)=dble(h(k1))+s(m1)*dble(h(k2))+s(l1)*(dble(h(k3))+s(m1)*dble(h(k4)))
else
t2=aimag(h(k2))
if (l1.gt.m2) t2=-t2
t3=aimag(h(k3))
if (l2.gt.m1) t3=-t3
t4=aimag(h(k4))
if (l2.gt.m2) t4=-t4
rh(k1)=aimag(h(k1))+s(m1)*t2+s(l1)*(t3+s(m1)*t4)
if (.not.tr(l1)) rh(k1)=-rh(k1)
end if
end do
end do
!-----------------------------!
! real overlap matrix !
!-----------------------------!
allocate(ro(nmatp**2))
!
do j=1,ngp
k=(j-1)*nmatp+1
call dcopy(j,o(k),2,ro(k),1)
end do
!
do m1=1,nlotot
j1=ngp+m1
j2=ngp+idx(m1)
do i=1,ngp
k1=i+(j1-1)*nmatp
k2=i+(j2-1)*nmatp
o1=o(k1); o2=o(k2)
if (tp(m1)) then
o1=o1*zp(m1); o2=o2*zp(m1)
end if
if (tr(m1)) then
ro(k1)=dble(o1)+s(m1)*dble(o2)
else
ro(k1)=aimag(o1)+s(m1)*aimag(o2)
end if
end do
end do
!
do m1=1,nlotot
m2=idx(m1)
do l1=1,m1
l2=idx(l1)
k1=map(l1,m1); k2=map(l1,m2); k3=map(l2,m1); k4=map(l2,m2)
if ((tr(l1).and.tr(m1)).or.((.not.tr(l1)).and.(.not.tr(m1)))) then
ro(k1)=dble(o(k1))+s(m1)*dble(o(k2))+s(l1)*(dble(o(k3))+s(m1)*dble(o(k4)))
else
t2=aimag(o(k2))
if (l1.gt.m2) t2=-t2
t3=aimag(o(k3))
if (l2.gt.m1) t3=-t3
t4=aimag(o(k4))
if (l2.gt.m2) t4=-t4
ro(k1)=aimag(o(k1))+s(m1)*t2+s(l1)*(t3+s(m1)*t4)
if (.not.tr(l1)) ro(k1)=-ro(k1)
end if
end do
end do
! solve the generalised eigenvalue problem for real symmetric matrices
allocate(iwork(5*nmatp),ifail(nmatp))
allocate(w(nmatp),rv(nmatp,nstfv))
lwork=8*nmatp
allocate(work(lwork))
! enable MKL parallelism
call holdthd(maxthdmkl,nthd)
call mkl_set_num_threads(nthd)
! diagonalise the matrix
call dsygvx(1,'V','I','U',nmatp,rh,nmatp,ro,nmatp,vl,vu,1,nstfv,evaltol,m,w, &
rv,nmatp,work,lwork,iwork,ifail,info)
call freethd(nthd)
call mkl_set_num_threads(1)
if (info.ne.0) then
write(*,*)
write(*,'("Error(eveqnfvr): diagonalisation failed")')
write(*,'(" DSYGVX returned INFO = ",I8)') info
if (info.gt.nmatp) then
i=info-nmatp
write(*,'(" The leading minor of the overlap matrix of order ",I8)') i
write(*,'(" is not positive definite")')
write(*,'(" Order of overlap matrix : ",I8)') nmatp
end if
write(*,*)
stop
end if
evalfv(1:nstfv)=w(1:nstfv)
! reconstruct the complex eigenvectors
do j=1,nstfv
evecfv(1:ngp,j)=rv(1:ngp,j)
evecfv(ngp+1:nmatp,j)=0.d0
do l1=1,nlotot
i1=ngp+l1
i2=ngp+idx(l1)
t1=rv(i1,j)
if (tr(l1)) then
evecfv(i1,j)=evecfv(i1,j)+t1
evecfv(i2,j)=evecfv(i2,j)+s(l1)*t1
else
evecfv(i1,j)=evecfv(i1,j)-cmplx(0.d0,t1,8)
evecfv(i2,j)=evecfv(i2,j)-cmplx(0.d0,s(l1)*t1,8)
end if
end do
do l1=1,nlotot
if (tp(l1)) then
i1=ngp+l1
evecfv(i1,j)=evecfv(i1,j)*zp(l1)
end if
end do
end do
deallocate(iwork,ifail,w,rv,work)
deallocate(tr,tp,idx,s,map,rh,ro,zp)
call timesec(ts1)
!$OMP ATOMIC
timefv=timefv+ts1-ts0
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/findsym.f90 0000644 0000000 0000000 00000000132 13543334734 014617 x ustar 00 30 mtime=1569569244.633641942
30 atime=1569569240.796644393
30 ctime=1569569244.633641942
elk-6.3.2/src/findsym.f90 0000644 0025044 0025044 00000013163 13543334734 016672 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007-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: findsym
! !INTERFACE:
subroutine findsym(apl1,apl2,nsym,lspl,lspn,iea)
! !USES:
use modmain
use moddftu
! !INPUT/OUTPUT PARAMETERS:
! apl1 : first set of atomic positions in lattice coordinates
! (in,real(3,maxatoms,maxspecies))
! apl2 : second set of atomic positions in lattice coordinates
! (in,real(3,maxatoms,maxspecies))
! nsym : number of symmetries (out,integer)
! lspl : spatial rotation element in lattice point group for each symmetry
! (out,integer(48))
! lspn : spin rotation element in lattice point group for each symmetry
! (out,integer(48))
! iea : equivalent atom index for each symmetry
! (out,integer(iea(natmmax,nspecies,48))
! !DESCRIPTION:
! Finds the symmetries which rotate one set of atomic positions into another.
! Both sets of positions differ only by a translation vector and have the same
! muffin-tin magnetic fields (stored in the global array {\tt bfcmt}). Any
! symmetry element consists of a spatial rotation of the atomic position
! vectors followed by a global magnetic rotation: $\{\alpha_S|\alpha_R\}$. In
! the case of spin-orbit coupling $\alpha_S=\alpha_R$. The symmetries are
! returned as indices of elements in the Bravais lattice point group. An
! index to equivalent atoms is stored in the array {\tt iea}.
!
! !REVISION HISTORY:
! Created April 2007 (JKD)
! Fixed use of proper rotations for spin, February 2008 (L. Nordstrom)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: apl1(3,maxatoms,maxspecies)
real(8), intent(in) :: apl2(3,maxatoms,maxspecies)
integer, intent(out) :: nsym
integer, intent(out) :: lspl(48)
integer, intent(out) :: lspn(48)
integer, intent(out) :: iea(natmmax,nspecies,48)
! local variables
integer isym,jsym,jsym0,jsym1
integer is,ia,ias,ja,jas,md,n
real(8) sl(3,3),sc(3,3),v(3),t1
! automatic arrays
integer jea(natmmax,nspecies)
real(8) apl3(3,natmmax)
! allocatable arrays
complex(8), allocatable :: dmat(:,:,:,:)
! external functions
real(8) dnrm2
external dnrm2
nsym=0
! loop over lattice symmetries (spatial rotations)
do isym=1,nsymlat
! make real copy of lattice rotation symmetry
sl(:,:)=dble(symlat(:,:,isym))
! loop over species
do is=1,nspecies
! map apl1 coordinates to [0,1) and store in apl3
do ia=1,natoms(is)
apl3(:,ia)=apl1(:,ia,is)
call r3frac(epslat,apl3(:,ia))
end do
do ja=1,natoms(is)
! apply lattice symmetry to atomic positions
v(:)=sl(:,1)*apl2(1,ja,is)+sl(:,2)*apl2(2,ja,is)+sl(:,3)*apl2(3,ja,is)
! map coordinates to [0,1)
call r3frac(epslat,v)
! check if atomic positions are invariant
do ia=1,natoms(is)
t1=abs(apl3(1,ia)-v(1))+abs(apl3(2,ia)-v(2))+abs(apl3(3,ia)-v(3))
if (t1.lt.epslat) then
! equivalent atom index
jea(ia,is)=ja
goto 10
end if
end do
! not invariant so try new spatial rotation
goto 40
10 continue
end do
end do
! all atomic positions invariant at this point
jsym=1
! spin polarised case
if (spinpol) then
! check invariance of magnetic fields under global spin rotation
if (spinorb) then
! with spin-orbit coupling spin rotation equals spatial rotation
jsym0=isym
jsym1=isym
else
! without spin-orbit coupling spin rotation independent of spatial rotation
jsym0=1
jsym1=nsymlat
end if
do jsym=jsym0,jsym1
! determinant of the symmetry matrix
md=symlatd(jsym)
sc(:,:)=dble(md)*symlatc(:,:,jsym)
! rotate global field and check invariance using proper part of symmetry matrix
v(:)=sc(:,1)*bfieldc0(1)+sc(:,2)*bfieldc0(2)+sc(:,3)*bfieldc0(3)
t1=abs(bfieldc0(1)-v(1))+abs(bfieldc0(2)-v(2))+abs(bfieldc0(3)-v(3))
! if not invariant try a different global spin rotation
if (t1.gt.epslat) goto 20
! rotate muffin-tin magnetic fields and check invariance
do is=1,nspecies
do ia=1,natoms(is)
! equivalent atom
ja=jea(ia,is)
v(:)=sc(:,1)*bfcmt0(1,ja,is) &
+sc(:,2)*bfcmt0(2,ja,is) &
+sc(:,3)*bfcmt0(3,ja,is)
t1=abs(bfcmt0(1,ia,is)-v(1)) &
+abs(bfcmt0(2,ia,is)-v(2)) &
+abs(bfcmt0(3,ia,is)-v(3))
! if not invariant try a different global spin rotation
if (t1.gt.epslat) goto 20
end do
end do
! all fields invariant
goto 30
20 continue
! end loop over global spin rotations
end do
! magnetic fields not invariant so try different spatial rotation
goto 40
end if
30 continue
! check invariance of density matrices for fixed tensor moment calculations
if (ftmtype.ne.0) then
allocate(dmat(lmmaxdm,nspinor,lmmaxdm,nspinor))
n=2*(lmmaxdm*nspinor)**2
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
! equivalent atom
ja=jea(ia,is)
jas=idxas(ja,is)
! rotate the fixed tensor moment density matrix
dmat(:,:,:,:)=0.d0
call rotdmat(symlatc(:,:,isym),symlatc(:,:,jsym),lmaxdm,nspinor, &
lmmaxdm,dmftm(:,:,:,:,jas),dmat)
! check invariance
call daxpy(n,-1.d0,dmftm(:,:,:,:,ias),1,dmat,1)
t1=dnrm2(n,dmat,1)/dble(n)
if (t1.gt.epslat) then
deallocate(dmat)
goto 40
end if
end do
end do
deallocate(dmat)
end if
! everything invariant so add symmetry to set
nsym=nsym+1
lspl(nsym)=isym
lspn(nsym)=jsym
do is=1,nspecies
do ia=1,natoms(is)
iea(ia,is,nsym)=jea(ia,is)
end do
end do
40 continue
! end loop over spatial rotations
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/genvbmatk.f90 0000644 0000000 0000000 00000000131 13543334734 015123 x ustar 00 30 mtime=1569569244.638641939
29 atime=1569569240.80164439
30 ctime=1569569244.638641939
elk-6.3.2/src/genvbmatk.f90 0000644 0025044 0025044 00000010003 13543334734 017165 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 K. Krieger, 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 genvbmatk(vmt,vir,bmt,bir,ngp,igpig,wfmt,ld,wfgp,vbmat)
use modmain
use modomp
implicit none
! arguments
real(8), intent(in) :: vmt(npcmtmax,natmtot),vir(ngtot)
real(8), intent(in) :: bmt(npcmtmax,natmtot,ndmag),bir(ngtot,ndmag)
integer, intent(in) :: ngp(nspnfv),igpig(ngkmax,nspnfv)
complex(8), intent(in) :: wfmt(npcmtmax,natmtot,nspinor,nstsv)
integer, intent(in) :: ld
complex(8), intent(in) :: wfgp(ld,nspinor,nstsv)
complex(8), intent(out) :: vbmat(nstsv,nstsv)
! local variables
integer ist,jst,ispn,jspn
integer is,ias,nrc,nrci
integer npc,igp,nthd
! allocatable arrays
complex(8), allocatable :: wfmt1(:,:),wfir(:,:),z(:)
! external functions
complex(8) zfcmtinp,zdotc
external zfcmtinp,zdotc
! zero the matrix elements
vbmat(:,:)=0.d0
!-------------------------!
! muffin-tin part !
!-------------------------!
call holdthd(nstsv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfmt1,ias,is,nrc) &
!$OMP PRIVATE(nrci,npc,ispn,ist) &
!$OMP NUM_THREADS(nthd)
allocate(wfmt1(npcmtmax,nspinor))
!$OMP DO
do jst=1,nstsv
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ispn=1,nspinor
call zcopy(npc,wfmt(:,ias,ispn,jst),1,wfmt1(:,ispn),1)
end do
! apply local potential and magnetic field to spinor wavefunction
if (ncmag) then
! non-collinear case
call vbmk1(npc,vmt(:,ias),bmt(:,ias,1),bmt(:,ias,2),bmt(:,ias,3),wfmt1, &
wfmt1(:,2))
else
! collinear case
call vbmk2(npc,vmt(:,ias),bmt(:,ias,1),wfmt1,wfmt1(:,2))
end if
do ist=1,jst
do ispn=1,nspinor
! compute inner product (functions are in spherical coordinates)
vbmat(ist,jst)=vbmat(ist,jst)+zfcmtinp(nrc,nrci,wrcmt(:,is), &
wfmt(:,ias,ispn,ist),wfmt1(:,ispn))
end do
end do
end do
end do
!$OMP END DO
deallocate(wfmt1)
!$OMP END PARALLEL
call freethd(nthd)
!---------------------------!
! interstitial part !
!---------------------------!
call holdthd(nstsv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfir,z,ispn,jspn) &
!$OMP PRIVATE(igp,ist) &
!$OMP NUM_THREADS(nthd)
allocate(wfir(ngtot,nspinor),z(ngkmax))
!$OMP DO
do jst=1,nstsv
! Fourier transform wavefunction to real-space
do ispn=1,nspinor
jspn=jspnfv(ispn)
wfir(:,ispn)=0.d0
do igp=1,ngp(jspn)
wfir(igfft(igpig(igp,jspn)),ispn)=wfgp(igp,ispn,jst)
end do
call zfftifc(3,ngridg,1,wfir(:,ispn))
end do
! apply local potential and magnetic field to spinor wavefunction
if (ncmag) then
! non-collinear case
call vbmk1(ngtot,vir,bir,bir(:,2),bir(:,3),wfir,wfir(:,2))
else
! collinear case
call vbmk2(ngtot,vir,bir,wfir,wfir(:,2))
end if
do ispn=1,nspinor
jspn=jspnfv(ispn)
! Fourier transform to G+p-space
call zfftifc(3,ngridg,-1,wfir(:,ispn))
do igp=1,ngp(jspn)
z(igp)=wfir(igfft(igpig(igp,jspn)),ispn)
end do
do ist=1,jst
vbmat(ist,jst)=vbmat(ist,jst)+zdotc(ngp(jspn),wfgp(:,ispn,ist),1,z,1)
end do
end do
end do
!$OMP END DO
deallocate(wfir,z)
!$OMP END PARALLEL
call freethd(nthd)
! lower triangular part
do ist=1,nstsv
do jst=1,ist-1
vbmat(ist,jst)=conjg(vbmat(jst,ist))
end do
end do
return
contains
pure subroutine vbmk1(n,v,b1,b2,b3,wf1,wf2)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: v(n),b1(n),b2(n),b3(n)
complex(8), intent(inout) :: wf1(n),wf2(n)
! local variables
integer i
real(8) t1
complex(8) z1,z2
do i=1,n
z2=cmplx(b1(i),b2(i),8)
t1=b3(i)
z1=(v(i)+t1)*wf1(i)+conjg(z2)*wf2(i)
wf2(i)=(v(i)-t1)*wf2(i)+z2*wf1(i)
wf1(i)=z1
end do
return
end subroutine
pure subroutine vbmk2(n,v,b,wf1,wf2)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(in) :: v(n),b(n)
complex(8), intent(inout) :: wf1(n),wf2(n)
! local variables
integer i
do i=1,n
wf1(i)=(v(i)+b(i))*wf1(i)
wf2(i)=(v(i)-b(i))*wf2(i)
end do
return
end subroutine
end subroutine
elk-6.3.2/src/PaxHeaders.21352/wigner3jf.f90 0000644 0000000 0000000 00000000132 13543334734 015044 x ustar 00 30 mtime=1569569244.642641937
30 atime=1569569240.806644387
30 ctime=1569569244.642641937
elk-6.3.2/src/wigner3jf.f90 0000644 0025044 0025044 00000005255 13543334734 017122 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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.
!BOP
! !ROUTINE: wigner3jf
! !INTERFACE:
real(8) function wigner3jf(j12,j22,j32,m12,m22,m32)
! !INPUT/OUTPUT PARAMETERS:
! j12, j22, j32 : angular momentum quantum numbers times 2 (in,integer)
! m12, m22, m32 : magnetic quantum numbers times 2 (in,integer)
! !DESCRIPTION:
! Returns the Wigner $3j$-symbol for the case where the arguments may be
! fractional, i.e. multiples of $\frac{1}{2}$. The input parameters to this
! function are taken to be twice their actual values, which allows them to
! remain integers. The formula used is identical to that in {\tt wigner3j}.
!
! !REVISION HISTORY:
! Created January 2014 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: j12,j22,j32
integer, intent(in) :: m12,m22,m32
! local variables
integer jm1,jm2,jm3,n1,n2
integer l12,l22,l32,l42
integer k,k1,k2,l1,l2,l3
real(8) sgn,sum,t1
! external functions
real(8) factnm,factr
external factnm,factr
! check input variables
if ((j12.lt.0).or.(j22.lt.0).or.(j32.lt.0).or.(abs(m12).gt.j12).or. &
(abs(m22).gt.j22).or.(abs(m32).gt.j32)) then
write(*,*)
write(*,'("Error(wigner3jf): invalid arguments :")')
write(*,'("j12 = ",I8," j22 = ",I8," j32 = ",I8)') j12,j22,j32
write(*,'("m12 = ",I8," m22 = ",I8," m32 = ",I8)') m12,m22,m32
write(*,*)
stop
end if
if ((j12.eq.0).and.(j22.eq.0).and.(j32.eq.0)) then
wigner3jf=1.d0
return
end if
if ((j12.gt.100).or.(j22.gt.100).or.(j32.gt.100)) then
write(*,*)
write(*,'("Error(wigner3jf): angular momenta out of range : ",3I8)') j12, &
j22,j32
write(*,*)
stop
end if
jm1=j12+m12
jm2=j22+m22
jm3=j32+m32
if ((mod(jm1,2).ne.0).or.(mod(jm2,2).ne.0).or.(mod(jm3,2).ne.0)) then
wigner3jf=0.d0
return
end if
l12=j22-j12+j32
l22=j12-j22+j32
l32=j12+j22-j32
l42=j12+j22+j32
if ((mod(l12,2).ne.0).or.(mod(l22,2).ne.0).or.(mod(l32,2).ne.0).or. &
(mod(l42,2).ne.0)) then
wigner3jf=0.d0
return
end if
l1=l12/2
l2=l22/2
l3=l32/2
if ((m12+m22+m32.ne.0).or.(l1.lt.0).or.(l2.lt.0).or.(l3.lt.0)) then
wigner3jf=0.d0
return
end if
n1=(j12-m12)/2
n2=(j22+m22)/2
k1=max(0,n1-l2,n2-l1)
k2=min(l3,n1,n2)
k=k1+(j22-j12+m32)/2
if (mod(k,2).ne.0) then
sgn=-1.d0
else
sgn=1.d0
end if
sum=0.d0
do k=k1,k2
t1=sgn*factr(l1,l1-n2+k)*factr(l2,l2-n1+k)*factr(l3,l3-k)
sum=sum+t1/(factnm(k,1)*factnm(n1-k,1)*factnm(n2-k,1))
sgn=-sgn
end do
jm1=jm1/2
jm2=jm2/2
jm3=jm3/2
t1=factr(jm1,l1)*factr(jm2,l2)*factr(jm3,l3)
jm1=(j12-m12)/2
jm2=(j22-m22)/2
jm3=(j32-m32)/2
t1=t1*factr(jm3,1+l42/2)*factnm(jm1,1)*factnm(jm2,1)
wigner3jf=sum*sqrt(t1)
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/wigner6j.f90 0000644 0000000 0000000 00000000132 13543334734 014701 x ustar 00 30 mtime=1569569244.647641933
30 atime=1569569240.812644383
30 ctime=1569569244.647641933
elk-6.3.2/src/wigner6j.f90 0000644 0025044 0025044 00000006154 13543334734 016756 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2009 F. Bultmark, F. Cricchio, L. Nordstrom and J. K. Dewhurst.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: wigner6j
! !INTERFACE:
real(8) function wigner6j(j1,j2,j3,k1,k2,k3)
! !INPUT/OUTPUT PARAMETERS:
! j1, j2, j3 : angular momentum quantum numbers (in,integer)
! k1, k2, k3 : angular momentum quantum numbers (in,integer)
! !DESCRIPTION:
! Returns the Wigner $6j$-symbol for integer arguments. This is computed using
! the Racah formula:
! \begin{align*}
! &\left\{\begin{matrix} j_1 & j_2 & j_3 \\ k_1 & k_2 & k_3 \end{matrix}
! \right\}=\sqrt{\Delta(j_1\,j_2\,j_3)\Delta(j_1\,k_2\,k_3)
! \Delta(k_1\,j_2\,k_3)\Delta(k_1\,k_2\,j_3)}\,
! \sum_n\frac{(-1)^n(n+1)!}{f(n)},
! \end{align*}
! where
! \begin{align*}
! f(n)=&(n-j_1-j_2-j_3)!\,(n-j_1-k_2-k_3)!\,(n-k_1-j_2-k_3)!\,
! (n-k_1-k_2-j_3)! \\
! &\times(j_1+j_2+k_1+k_2-n)!\,(j_2+j_3+k_2+k_3-n)!\,(j_1+j_3+k_1+k_3-n)!
! \end{align*}
! and
! $$ \Delta(a,b,c)=\frac{(a+b-c)!\,(a-b+c)!\,(-a+b+c)!}{(a+b+c+1)!} $$
! is the triangle coefficient, and where the sum is over all integers $n$ for
! which the factorials in $f(n)$ have non-negative arguments. The Wigner-$6j$
! function is zero unless each triad, $(j_1\,j_2\,j_3)$, $(j_1\,k_2\,k_3)$,
! $(k_1\,j_2\,k_3)$ and $(k_1\,k_2\,j_3)$, satifies the triangle inequalities:
! $$ |x-y|\le z \le x+y, $$
! for triad $(x,y,z)$. See, for example, A. Messiah, {\it Quantum Mechanics},
! Vol. 2., 1061-1066 (1962).
!
! !REVISION HISTORY:
! Created August 2009 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: j1,j2,j3
integer, intent(in) :: k1,k2,k3
! local variables
integer n0,n1,n
real(8) sum,t1,t2
! external functions
real(8) triangle,factnm,factr
external triangle,factnm,factr
wigner6j=0.d0
if ((abs(j1-j2).gt.j3).or.((j1+j2).lt.j3)) return
if ((abs(j1-k2).gt.k3).or.((j1+k2).lt.k3)) return
if ((abs(k1-j2).gt.k3).or.((k1+j2).lt.k3)) return
if ((abs(k1-k2).gt.j3).or.((k1+k2).lt.j3)) return
if ((abs(j1).gt.50).or.(abs(j2).gt.50).or.(abs(j3).gt.50).or. &
(abs(k1).gt.50).or.(abs(k2).gt.50).or.(abs(k3).gt.50)) then
write(*,*)
write(*,'("Error(wigner6j): arguments out of range :")')
write(*,'(" j1, j2, j3 = ",3I8)') j1,j2,j3
write(*,'(" k1, k2, k3 = ",3I8)') k1,k2,k3
write(*,*)
stop
end if
! range for summation
n0=max(j1+j2+j3,j1+k2+k3,k1+j2+k3,k1+k2+j3)
n1=min(j1+j2+k1+k2,j2+j3+k2+k3,j1+j3+k1+k3)
! Racah formula summation
sum=0.d0
do n=n0,n1
t1=dble((-1)**n)*factr(n+1,n-(j1+j2+j3))
t2=factnm(n-(j1+k2+k3),1)*factnm(n-(k1+j2+k3),1)*factnm(n-(k1+k2+j3),1)
t2=t2*factnm(j1+j2+k1+k2-n,1)*factnm(j2+j3+k2+k3-n,1)*factnm(j1+j3+k1+k3-n,1)
sum=sum+t1/t2
end do
! multiply by prefactor
wigner6j=sqrt(triangle(j1,j2,j3)*triangle(j1,k2,k3) &
*triangle(k1,j2,k3)*triangle(k1,k2,j3))*sum
return
end function
real(8) function triangle(a,b,c)
implicit none
! arguments
integer, intent(in) :: a,b,c
! external functions
real(8) factnm,factr
external factnm,factr
triangle=factr(a+b-c,a+b+c+1)*factnm(a-b+c,1)*factnm(-a+b+c,1)
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/mixbroyden.f90 0000644 0000000 0000000 00000000131 13543334734 015325 x ustar 00 30 mtime=1569569244.651641931
29 atime=1569569240.81664438
30 ctime=1569569244.651641931
elk-6.3.2/src/mixbroyden.f90 0000644 0025044 0025044 00000004470 13543334734 017402 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 Lesser General Public
! License. See the file COPYING for license details.
subroutine mixbroyden(iscl,n,msd,alpha,w0,nu,mu,f,df,u,a,d)
use modomp
implicit none
! arguments
integer, intent(in) :: iscl,n,msd
real(8), intent(in) :: alpha,w0
real(8), intent(inout) :: nu(n),mu(n,2)
real(8), intent(inout) :: f(n,2),df(n,msd)
real(8), intent(inout) :: u(n,msd)
real(8), intent(inout) :: a(msd,msd)
real(8), intent(out) :: d
! local variables
integer jc,kp,kc
integer k,l,m
integer info,nthd
real(8) t1
! automatic arrays
integer ipiv(msd)
real(8) c(msd),beta(msd,msd),gamma(msd)
real(8) work(msd)
! external functions
real(8) dnrm2
external dnrm2
if (n.lt.1) then
write(*,*)
write(*,'("Error(mixbroyden): n < 1 : ",I8)') n
write(*,*)
stop
end if
if (msd.lt.2) then
write(*,*)
write(*,'("Error(mixbroyden): msd < 2 : ",I8)') msd
write(*,*)
stop
end if
! initialise mixer
if (iscl.le.0) then
call dcopy(n,nu,1,mu(:,1),1)
call dcopy(n,nu,1,mu(:,2),1)
f(:,1)=0.d0
df(:,1)=0.d0
u(:,1)=0.d0
a(:,:)=0.d0
d=1.d0
return
end if
! current subspace dimension
m=min(iscl+1,msd)
! current index modulo m
jc=mod(iscl,m)+1
! previous index modulo 2
kp=mod(iscl-1,2)+1
! current index modulo 2
kc=mod(iscl,2)+1
f(:,kc)=nu(:)-mu(:,kp)
d=sum(f(:,kc)**2)
d=sqrt(d/dble(n))
df(:,jc)=f(:,kc)-f(:,kp)
t1=dnrm2(n,df(:,jc),1)
if (t1.gt.1.d-8) t1=1.d0/t1
call dscal(n,t1,df(:,jc),1)
u(:,jc)=alpha*df(:,jc)+t1*(mu(:,kp)-mu(:,kc))
call holdthd(m,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do k=1,m
c(k)=dot_product(df(:,k),f(:,kc))
end do
!$OMP END DO NOWAIT
!$OMP DO
do k=1,m
a(k,jc)=dot_product(df(:,jc),df(:,k))
a(jc,k)=a(k,jc)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
beta(:,:)=a(:,:)
do k=1,m
beta(k,k)=beta(k,k)+w0**2
end do
! invert beta
call dgetrf(m,m,beta,msd,ipiv,info)
if (info.eq.0) call dgetri(m,beta,msd,ipiv,work,m,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(mixbroyden): could not invert matrix")')
write(*,*)
stop
end if
do l=1,m
gamma(l)=0.d0
do k=1,m
gamma(l)=gamma(l)+c(k)*beta(k,l)
end do
end do
nu(:)=mu(:,kp)+alpha*f(:,kc)
do l=1,m
call daxpy(n,-gamma(l),u(:,l),1,nu,1)
end do
call dcopy(n,nu,1,mu(:,kc),1)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zftrf.f90 0000644 0000000 0000000 00000000132 13543334734 014301 x ustar 00 30 mtime=1569569244.656641928
30 atime=1569569240.822644376
30 ctime=1569569244.656641928
elk-6.3.2/src/zftrf.f90 0000644 0025044 0025044 00000012403 13543334734 016350 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 Alexey I. Baranov.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: zftrf
! !INTERFACE:
subroutine zftrf(npv,ivp,vpc,rfmt,rfir,zfp)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! npv : number of P-vectors (in,integer)
! ivp : integer coordinates of the P-vectors (in,integer(3,npv))
! vpc : P-vectors in Cartesian coordinates (in,real(3,npv))
! rfmt : real muffin-tin function (in,real(npmtmax,natmtot))
! rfir : real interstitial function (in,real(ngtot))
! zfp : Fourier expansion coefficients of the real-space function
! (out,complex(npv))
! !DESCRIPTION:
! Given a real function periodic in the unit cell, $f({\bf r})$, this routine
! calculates its complex Fourier expansion coefficients:
! $$ f({\bf P})=\frac{1}{\Omega}\int d^3r\,f({\bf r})\tilde{\Theta}({\bf r})
! e^{-i{\bf P}\cdot{\bf r}}
! +\frac{4\pi}{\Omega}\sum_{\alpha}e^{-i{\bf P}\cdot{\bf R}_{\alpha}}
! \sum_{lm}(-i)^l Y_{lm}(\hat{\bf P})
! \int_{0}^{R_{\alpha}}dr\,r^2 j_{l}(|{\bf P}|r)f_{lm}^{\alpha}(r), $$
! where $\tilde{\Theta}$ is the smooth characteristic function of the
! interstitial region, $\Omega$ is the unit cell volume and $R_{\alpha}$ is
! the muffin-tin radius of atom $\alpha$.
!
! !REVISION HISTORY:
! Created July 2010 (Alexey I. Baranov)
! Modified, November 2010 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: npv,ivp(3,npv)
real(8), intent(in) :: vpc(3,npv)
real(8), intent(in) :: rfmt(npmtmax,natmtot),rfir(ngtot)
complex(8), intent(out) :: zfp(npv)
! local variables
integer is,ia,ias
integer nrc,nrci,irco,irc
integer lmax,l,m,lm,npci,i
integer ip,ig,ifg
real(8) p,t0,t1,t2,t3
complex(8) z1,z2,z3
! automatic arrays
real(8) jl(0:lmaxo,nrcmtmax)
real(8) fr1(nrcmtmax),fr2(nrcmtmax),rfmt1(npcmtmax)
complex(8) ylm(lmmaxo)
! allocatable arrays
complex(8), allocatable :: zfft(:),zfmt(:,:)
allocate(zfft(ngtot),zfmt(npcmtmax,natmtot))
! zero the coefficients
zfp(:)=0.d0
!---------------------------!
! interstitial part !
!---------------------------!
! Fourier transform to G-space
zfft(:)=rfir(:)
call zfftifc(3,ngridg,-1,zfft)
! find coefficients for all required input vectors
do ip=1,npv
if ((ivp(1,ip).ge.intgv(1,1)).and.(ivp(1,ip).le.intgv(2,1)).and. &
(ivp(2,ip).ge.intgv(1,2)).and.(ivp(2,ip).le.intgv(2,2)).and. &
(ivp(3,ip).ge.intgv(1,3)).and.(ivp(3,ip).le.intgv(2,3))) then
ig=ivgig(ivp(1,ip),ivp(2,ip),ivp(3,ip))
zfp(ip)=zfft(igfft(ig))
end if
end do
!-------------------------!
! muffin-tin part !
!-------------------------!
! convert function from real to complex spherical harmonic expansion on coarse
! radial mesh
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
call rfmtftoc(nrc,nrci,rfmt(:,ias),rfmt1)
call rtozfmt(nrc,nrci,rfmt1,zfmt(:,ias))
end do
! remove continuation of interstitial function into muffin-tin
do ig=1,ngtot
ifg=igfft(ig)
! conjugate spherical harmonics Y_lm*(G)
call genylmv(lmaxo,vgc(:,ig),ylm)
ylm(:)=conjg(ylm(:))
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
irco=nrci+1
npci=npcmti(is)
! generate spherical Bessel functions
lmax=lmaxi
do irc=1,nrc
t1=gc(ig)*rcmt(irc,is)
call sbessel(lmax,t1,jl(:,irc))
if (irc.eq.nrci) lmax=lmaxo
end do
do ia=1,natoms(is)
ias=idxas(ia,is)
! structure factor
t1=dot_product(vgc(:,ig),atposc(:,ia,is))
z1=fourpi*zfft(ifg)*cmplx(cos(t1),sin(t1),8)
lm=0
do l=0,lmaxi
z2=z1*zil(l)
do m=-l,l
lm=lm+1
z3=z2*ylm(lm)
i=lm
do irc=1,nrci
zfmt(i,ias)=zfmt(i,ias)-z3*jl(l,irc)
i=i+lmmaxi
end do
end do
end do
lm=0
do l=0,lmaxo
z2=z1*zil(l)
do m=-l,l
lm=lm+1
z3=z2*ylm(lm)
i=npci+lm
do irc=irco,nrc
zfmt(i,ias)=zfmt(i,ias)-z3*jl(l,irc)
i=i+lmmaxo
end do
end do
end do
end do
end do
end do
t0=fourpi/omega
! loop over input P-vectors
do ip=1,npv
! length of P-vector
p=sqrt(vpc(1,ip)**2+vpc(2,ip)**2+vpc(3,ip)**2)
! spherical harmonics Y_lm(P)
call genylmv(lmaxo,vpc(:,ip),ylm)
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
! generate spherical Bessel functions
lmax=lmaxi
do irc=1,nrc
t1=p*rcmt(irc,is)
call sbessel(lmax,t1,jl(:,irc))
if (irc.eq.nrci) lmax=lmaxo
end do
do ia=1,natoms(is)
ias=idxas(ia,is)
lmax=lmaxi
i=0
do irc=1,nrc
i=i+1
z1=jl(0,irc)*zfmt(i,ias)*ylm(1)
lm=1
do l=1,lmax
lm=lm+1
i=i+1
z2=zfmt(i,ias)*ylm(lm)
do m=1-l,l
lm=lm+1
i=i+1
z2=z2+zfmt(i,ias)*ylm(lm)
end do
z1=z1+jl(l,irc)*zilc(l)*z2
end do
fr1(irc)=dble(z1); fr2(irc)=aimag(z1)
if (irc.eq.nrci) lmax=lmaxo
end do
t1=dot_product(wrcmt(1:nrc,is),fr1(1:nrc))
t2=dot_product(wrcmt(1:nrc,is),fr2(1:nrc))
! conjugate structure factor
t3=-dot_product(vpc(:,ip),atposc(:,ia,is))
z1=t0*cmplx(cos(t3),sin(t3),8)
zfp(ip)=zfp(ip)+z1*cmplx(t1,t2,8)
end do
end do
end do
deallocate(zfft,zfmt)
return
end subroutine
! EOC
elk-6.3.2/src/PaxHeaders.21352/gensocfr.f90 0000644 0000000 0000000 00000000132 13543334734 014754 x ustar 00 30 mtime=1569569244.660641925
30 atime=1569569240.827644373
30 ctime=1569569244.660641925
elk-6.3.2/src/gensocfr.f90 0000644 0025044 0025044 00000002152 13543334734 017023 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.
subroutine gensocfr
use modmain
use modomp
implicit none
! local variables
integer is,ias,nthd
integer nr,nri,ir,irc
real(8) cso,rm
! allocatable arrays
real(8), allocatable :: vr(:),dvr(:)
if (.not.spinorb) return
! coefficient of spin-orbit coupling
cso=socscf/(4.d0*solsc**2)
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(vr,dvr,is,nr,nri) &
!$OMP PRIVATE(irc,ir,rm) &
!$OMP NUM_THREADS(nthd)
allocate(vr(nrmtmax),dvr(nrmtmax))
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
! radial derivative of the spherical part of the Kohn-Sham potential
call rfmtlm(1,nr,nri,vsmt(:,ias),vr)
vr(1:nr)=vr(1:nr)*y00
call fderiv(1,nr,rlmt(:,1,is),vr,dvr)
irc=0
do ir=1,nr,lradstp
irc=irc+1
rm=1.d0-2.d0*cso*vr(ir)
socfr(irc,ias)=cso*dvr(ir)/(rsp(ir,is)*rm**2)
end do
end do
!$OMP END DO
deallocate(vr,dvr)
!$OMP END PARALLEL
call freethd(nthd)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/getcfgq.f90 0000644 0000000 0000000 00000000131 13543334734 014565 x ustar 00 30 mtime=1569569244.664641923
29 atime=1569569240.83264437
30 ctime=1569569244.664641923
elk-6.3.2/src/getcfgq.f90 0000644 0025044 0025044 00000007114 13543334734 016640 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.
subroutine getcfgq(fname,vpl,ng,m,cf)
use modmain
implicit none
! arguments
character(*), intent(in) :: fname
real(8), intent(in) :: vpl(3)
integer, intent(in) :: ng,m
complex(8), intent(out) :: cf(ng,ng,m)
! local variables
integer isym,iq,i
integer igq,jgq,igp,jgp
integer lspl,ilspl
integer recl,ng_,m_
real(8) vql_(3),si(3,3)
real(8) vgql(3),v(3),t1
complex(8) z1
! automatic arrays
logical done(ng)
! allocatable arrays
integer, allocatable :: map(:)
real(8), allocatable :: vgpl(:,:)
complex(8), allocatable :: cf_(:,:,:),x(:)
! find the equivalent reduced q-point and symmetry which rotates vql to vpl
call findqpt(vpl,isym,iq)
! find the record length
inquire(iolength=recl) vql(:,1),ng,m,cf
!$OMP CRITICAL(u180)
do i=1,2
open(180,file=trim(fname),form='UNFORMATTED',access='DIRECT',recl=recl,err=10)
read(180,rec=iq,err=10) vql_,ng_,m_,cf
exit
10 continue
if (i.eq.2) then
write(*,*)
write(*,'("Error(getcfgq): unable to read from ",A)') trim(fname)
write(*,*)
stop
end if
close(180)
end do
!$OMP END CRITICAL(u180)
t1=abs(vql(1,iq)-vql_(1))+abs(vql(2,iq)-vql_(2))+abs(vql(3,iq)-vql_(3))
if (t1.gt.epslat) then
write(*,*)
write(*,'("Error(getcfgq): differing vectors for q-point ",I8)') iq
write(*,'(" current : ",3G18.10)') vql(:,iq)
write(*,'(" file : ",3G18.10)') vql_
write(*,'(" in file ",A)') trim(fname)
write(*,*)
stop
end if
if (ng.ne.ng_) then
write(*,*)
write(*,'("Error(getcfgq): differing ng for q-point ",I8)') iq
write(*,'(" current : ",I8)') ng
write(*,'(" file : ",I8)') ng_
write(*,'(" in file ",A)') trim(fname)
write(*,*)
stop
end if
if (m.ne.m_) then
write(*,*)
write(*,'("Error(getcfgq): differing m for q-point ",I8)') iq
write(*,'(" current : ",I8)') m
write(*,'(" file : ",I8)') m_
write(*,'(" in file ",A)') trim(fname)
write(*,*)
stop
end if
! if p = q then return
t1=abs(vpl(1)-vql(1,iq))+abs(vpl(2)-vql(2,iq))+abs(vpl(3)-vql(3,iq))
if (t1.lt.epslat) return
! allocate local arrays
allocate(map(ng),vgpl(3,ng))
allocate(cf_(ng,ng,m),x(ng))
! perform translation operation and store in temporary array
if (tv0symc(isym)) then
! translation vector is zero
cf_(:,:,:)=cf(:,:,:)
else
! non-zero translation vector gives a phase factor
v(:)=vtcsymc(:,isym)
do igq=1,ng
t1=-(vgc(1,igq)*v(1)+vgc(2,igq)*v(2)+vgc(3,igq)*v(3))
x(igq)=cmplx(cos(t1),sin(t1),8)
end do
do jgq=1,ng
z1=conjg(x(jgq))
do igq=1,ng
cf_(igq,jgq,:)=z1*x(igq)*cf(igq,jgq,:)
end do
end do
end if
! index to spatial rotation in lattice point group
lspl=lsplsymc(isym)
! the inverse of the spatial symmetry
ilspl=isymlat(lspl)
si(:,:)=dble(symlat(:,:,ilspl))
! find the map from {G+q} to {G+p}
map(:)=0
do igp=1,ng
vgpl(:,igp)=dble(ivg(:,igp))+vpl(:)
end do
done(:)=.false.
i=1
do igq=1,ng
vgql(:)=dble(ivg(:,igq))+vql(:,iq)
call r3mtv(si,vgql,v)
do igp=i,ng
if (done(igp)) cycle
t1=abs(v(1)-vgpl(1,igp))+abs(v(2)-vgpl(2,igp))+abs(v(3)-vgpl(3,igp))
if (t1.lt.epslat) then
map(igp)=igq
done(igp)=.true.
exit
end if
end do
do igp=i,ng
if (.not.done(igp)) then
i=igp
exit
end if
end do
end do
! rotate correlation function (passive transformation)
do jgp=1,ng
jgq=map(jgp)
do igp=1,ng
igq=map(igp)
if ((igq.eq.0).or.(jgq.eq.0)) then
cf(igp,jgp,:)=0.d0
else
cf(igp,jgp,:)=cf_(igq,jgq,:)
end if
end do
end do
deallocate(map,vgpl,cf_,x)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/wigner3j.f90 0000644 0000000 0000000 00000000132 13543334734 014676 x ustar 00 30 mtime=1569569244.669641919
30 atime=1569569240.837644367
30 ctime=1569569244.669641919
elk-6.3.2/src/wigner3j.f90 0000644 0025044 0025044 00000005100 13543334734 016741 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: wigner3j
! !INTERFACE:
real(8) function wigner3j(j1,j2,j3,m1,m2,m3)
! !INPUT/OUTPUT PARAMETERS:
! j1, j2, j3 : angular momentum quantum numbers (in,integer)
! m1, m2, m3 : magnetic quantum numbers (in,integer)
! !DESCRIPTION:
! Returns the Wigner $3j$-symbol. There are many equivalent formulae for
! the $3j$-symbols, the following provides high accuracy for $j\le 50$
! \begin{align*}
! &\begin{pmatrix} j_1 & j_2 & j_3 \\ m_1 & m_2 & m_3 \end{pmatrix}= \\
! &(-1)^{j1+j2+m3}\sqrt{\frac{(j_1+m_1)!\,(j_2+m_2)!\,(j_3+m_3)!\,
! (j_3-m_3)!\,(j_1-m_1)!\,(j_2-m_2)!}{(j_2-j_1+j_3)!\,(j_1-j_2+j_3)!\,
! (j_1+j_2-j_3)!\,(1+j_1+j_2+j_3)!}}\,\sum_k(-1)^k \\
! &\frac{(j_2-j_1+j_3)!\,(j_1-j_2+j_3)!\,(j_1+j_2-j_3)!}{(j_3-j_1-m_2+k)!\,
! (j_3-j_2+m_1+k)!\,(j_1+j_2-j_3-k)!\,k!\,(j_1-m_1-k)!\,(j_2+m_2-k)!},
! \end{align*}
! where the sum is over all integers $k$ for which the factorials in the
! summand are non-negative.
!
! !REVISION HISTORY:
! Created November 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: j1,j2,j3
integer, intent(in) :: m1,m2,m3
! local variables
integer k,k1,k2,l1,l2,l3,n1,n2
real(8) sgn,sum,t1
! external functions
real(8) factnm,factr
external factnm,factr
! check input variables
if ((j1.lt.0).or.(j2.lt.0).or.(j3.lt.0).or.(abs(m1).gt.j1).or.(abs(m2).gt.j2) &
.or.(abs(m3).gt.j3)) then
write(*,*)
write(*,'("Error(wigner3j): invalid arguments :")')
write(*,'("j1 = ",I8," j2 = ",I8," j3 = ",I8)') j1,j2,j3
write(*,'("m1 = ",I8," m2 = ",I8," m3 = ",I8)') m1,m2,m3
write(*,*)
stop
end if
if ((j1.eq.0).and.(j2.eq.0).and.(j3.eq.0)) then
wigner3j=1.d0
return
end if
if ((j1.gt.50).or.(j2.gt.50).or.(j3.gt.50)) then
write(*,*)
write(*,'("Error(wigner3j): angular momenta out of range : ",3I8)') j1,j2,j3
write(*,*)
stop
end if
l1=j2-j1+j3
l2=j1-j2+j3
l3=j1+j2-j3
if ((m1+m2+m3.ne.0).or.(l1.lt.0).or.(l2.lt.0).or.(l3.lt.0)) then
wigner3j=0.d0
return
end if
n1=j1-m1
n2=j2+m2
k1=max(0,n1-l2,n2-l1)
k2=min(l3,n1,n2)
if (mod(k1-j1+j2+m3,2).ne.0) then
sgn=-1.d0
else
sgn=1.d0
end if
sum=0.d0
do k=k1,k2
t1=sgn*factr(l1,l1-n2+k)*factr(l2,l2-n1+k)*factr(l3,l3-k)
sum=sum+t1/(factnm(k,1)*factnm(n1-k,1)*factnm(n2-k,1))
sgn=-sgn
end do
t1=factr(j1+m1,l1)*factr(j2+m2,l2)*factr(j3+m3,l3)
t1=t1*factr(j3-m3,1+j1+j2+j3)*factnm(j1-m1,1)*factnm(j2-m2,1)
wigner3j=sum*sqrt(t1)
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/moke.f90 0000644 0000000 0000000 00000000132 13543334734 014101 x ustar 00 30 mtime=1569569244.673641917
30 atime=1569569240.842644364
30 ctime=1569569244.673641917
elk-6.3.2/src/moke.f90 0000644 0025044 0025044 00000004131 13543334734 016147 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 S. Sharma, J. K. Dewhurst 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 moke
use modmain
implicit none
! local variables
integer iw,ios
complex(8) z1,z2,z3
! allocatable arrays
real(8), allocatable :: w(:),sig1(:,:),sig2(:,:)
complex(8), allocatable :: kerr(:)
! calculate dielectric function for the 11 and 12 components
noptcomp=2
optcomp(1,1)=1
optcomp(2,1)=1
optcomp(1,2)=1
optcomp(2,2)=2
call dielectric
! allocate local arrays
allocate(w(nwplot))
allocate(sig1(nwplot,2),sig2(nwplot,2))
allocate(kerr(nwplot))
! read diagonal contribution to optical conductivity
open(50,file='SIGMA_11.OUT',status='OLD',form='FORMATTED',iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(moke): error opening SIGMA_11.OUT")')
write(*,*)
stop
end if
do iw=1,nwplot
read(50,'(2G18.10)') w(iw),sig1(iw,1)
end do
read(50,*)
do iw=1,nwplot
read(50,'(2G18.10)') w(iw),sig2(iw,1)
end do
close(50)
! read off-diagonal contribution to optical conductivity
open(50,file='SIGMA_12.OUT',status='OLD',form='FORMATTED',iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(moke): error opening SIGMA_12.OUT")')
write(*,*)
stop
end if
do iw=1,nwplot
read(50,'(2G18.10)') w(iw),sig1(iw,2)
end do
read(50,*)
do iw=1,nwplot
read(50,'(2G18.10)') w(iw),sig2(iw,2)
end do
close(50)
! calculate the complex Kerr angle
do iw=1,nwplot
if (w(iw).gt.0.d0) then
z1=cmplx(sig1(iw,1),sig2(iw,1),8)
z2=cmplx(sig1(iw,2),sig2(iw,2),8)
z3=z1*sqrt(1.d0+fourpi*zi*z1/w(iw))
if (abs(z3).gt.1.d-8) then
kerr(iw)=-z2/z3
else
kerr(iw)=0.d0
end if
else
kerr(iw)=0.d0
end if
end do
open(50,file='KERR.OUT',form='FORMATTED')
do iw=1,nwplot
write(50,'(2G18.10)') w(iw),dble(kerr(iw))*180.d0/pi
end do
write(50,'(" ")')
do iw=1,nwplot
write(50,'(2G18.10)') w(iw),aimag(kerr(iw))*180.d0/pi
end do
close(50)
write(*,*)
write(*,'("Info(moke):")')
write(*,'(" complex Kerr angle in degrees written to KERR.OUT")')
deallocate(w,sig1,sig2,kerr)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/sfacinit.f90 0000644 0000000 0000000 00000000131 13543334734 014745 x ustar 00 30 mtime=1569569244.678641914
29 atime=1569569240.84764436
30 ctime=1569569244.678641914
elk-6.3.2/src/sfacinit.f90 0000644 0025044 0025044 00000003537 13543334734 017025 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 A. I. Baranov and F. Wagner.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine sfacinit
use modmain
use modpw
implicit none
! local variables
logical trhonorm0
integer ik,ist,is,ias
! allocatable arrays
real(8), allocatable :: occcr0(:,:)
! initialise universal variables
call init0
call init1
! read density and potentials from file
call readstate
! use existing density if wsfac is default
if ((wsfac(1).le.-1.d6).or.(wsfac(2).ge.1.d6)) goto 10
! make a copy of the core state occupancies
allocate(occcr0(nstspmax,natmtot))
occcr0(:,:)=occcr(:,:)
! zero the core state occupancies for eigenvalues not in energy window
do ias=1,natmtot
is=idxis(ias)
do ist=1,nstsp(is)
if (spcore(ist,is)) then
if ((evalcr(ist,ias).lt.wsfac(1)).or.(evalcr(ist,ias).gt.wsfac(2))) then
occcr(ist,ias)=0.d0
end if
end if
end do
end do
! generate the core wavefunctions and densities
call gencore
! restore the core state occupancies
occcr(:,:)=occcr0(:,:)
deallocate(occcr0)
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
do ik=1,nkpt
! get the eigenvalues and occupancies from file
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
! zero occupancies for eigenvalues not in energy window
do ist=1,nstsv
if ((evalsv(ist,ik).lt.wsfac(1)).or.(evalsv(ist,ik).gt.wsfac(2))) then
occsv(ist,ik)=0.d0
end if
end do
end do
! computed density should not be normalised
trhonorm0=trhonorm
trhonorm=.false.
! generate the density and magnetisation
call rhomag
trhonorm=trhonorm0
10 continue
! generate the H-vectors
call genhvec
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/sfacrho.f90 0000644 0000000 0000000 00000000132 13543334734 014573 x ustar 00 30 mtime=1569569244.682641911
30 atime=1569569240.853644357
30 ctime=1569569244.682641911
elk-6.3.2/src/sfacrho.f90 0000644 0025044 0025044 00000005112 13543334734 016641 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 A. I. Baranov and F. Wagner.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: sfacrho
! !INTERFACE:
subroutine sfacrho
! !USES:
use modmain
use modpw
use modtest
! !DESCRIPTION:
! Outputs X-ray structure factors, i.e. the Fourier transform coefficients of
! the total electron density
! $$ F({\bf H})=\int_{\Omega}d^3r\,\rho({\bf r})e^{i{\bf H}\cdot{\bf r}}, $$
! to the file {\tt SFACRHO.OUT}. The lattice coordinates $(h,k,l)$ of the
! $\bf H$-vectors in this file are transformed by the matrix {\tt vhmat}. If
! and energy window is set using the variable {\tt wsfac}, then only those
! states within the window are used to compute the density. See also routines
! {\tt zftrf} and {\tt genhvec}.
!
! !REVISION HISTORY:
! Created July 2010 (Alexey I. Baranov)
! Added multiplicity of the H-vectors, Oct. 2010 (Alexey I. Baranov)
!EOP
!BOC
implicit none
! local variables
integer ih,iv(3)
real(8) v(3),a,b,r
! allocatable arrays
complex(8), allocatable :: zrhoh(:)
! initialise the structure factor specific variables
call sfacinit
! calculate the density structure factors
allocate(zrhoh(nhvec))
call zftrf(nhvec,ivh,vhc,rhomt,rhoir,zrhoh)
open(50,file='SFACRHO.OUT',form='FORMATTED')
write(50,*)
write(50,'("h k l indices transformed by vhmat matrix:")')
write(50,'(3G18.10)') vhmat(:,1)
write(50,'(3G18.10)') vhmat(:,2)
write(50,'(3G18.10)') vhmat(:,3)
write(50,*)
write(50,'(" h k l multipl. |H| Re(F)&
& Im(F) |F|")')
write(50,*)
do ih=1,nhvec
! apply transformation matrix
v(:)=vhmat(:,1)*dble(ivh(1,ih)) &
+vhmat(:,2)*dble(ivh(2,ih)) &
+vhmat(:,3)*dble(ivh(3,ih))
! in crystallography the forward Fourier transform of real-space density is
! usually done with positive phase and without 1/omega prefactor
a=dble(zrhoh(ih))*omega
b=-aimag(zrhoh(ih))*omega
r=abs(zrhoh(ih))*omega
iv(:)=nint(v(:))
if ((abs(v(1)-iv(1)).le.epslat).and. &
(abs(v(2)-iv(2)).le.epslat).and. &
(abs(v(3)-iv(3)).le.epslat)) then
! integer hkl
write(50,'(4I7,4G16.8)') iv(:),mulh(ih),hc(ih),a,b,r
else
! non-integer hkl
write(50,'(3F7.2,I7,4G16.8)') v(:),mulh(ih),hc(ih),a,b,r
end if
end do
close(50)
write(*,*)
write(*,'("Info(sfacrho): density structure factors written to SFACRHO.OUT")')
write(*,*)
write(*,'(" Energy window : ",2G18.10)') wsfac(:)
! write the structure factors to test file
call writetest(195,'density structure factors',nv=nhvec,tol=1.d-5,zva=zrhoh(:))
deallocate(zrhoh)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/sfacmag.f90 0000644 0000000 0000000 00000000132 13543334734 014547 x ustar 00 30 mtime=1569569244.687641908
30 atime=1569569240.858644353
30 ctime=1569569244.687641908
elk-6.3.2/src/sfacmag.f90 0000644 0025044 0025044 00000005515 13543334734 016624 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 A. I. Baranov and F. Wagner.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: sfacmag
! !INTERFACE:
subroutine sfacmag
! !USES:
use modmain
use modpw
use modtest
! !DESCRIPTION:
! Outputs magnetic structure factors, i.e. the Fourier transform coefficients
! of each component $j$ of magnetization ${\bf m}({\bf r})$,
! $$ F_j({\bf H})=\int_{\Omega}d^3r\,m_j({\bf r})e^{i{\bf H}\cdot{\bf r}}, $$
! to the files {\tt SFACMAG\_j.OUT}. The lattice coordinates $(h,k,l)$ of
! $\bf H$-vectors in this file are transformed by the matrix {\tt vhmat}. See
! also routines {\tt zftrf} and {\tt genhvec}.
!
! !REVISION HISTORY:
! Created July 2010 (Alexey I. Baranov)
! Added multiplicity of the H-vectors, Oct. 2010 (Alexey I. Baranov)
!EOP
!BOC
implicit none
! local variables
integer idm,ih,iv(3)
real(8) v(3),a,b,r
character(256) fname
! allocatable arrays
complex(8), allocatable :: zmagh(:)
if (.not.spinpol) return
! initialise the structure factor specific variables
call sfacinit
! generate the magnetic structure factors
allocate(zmagh(nhvec))
do idm=1,ndmag
call zftrf(nhvec,ivh,vhc,magmt(:,:,idm),magir(:,idm),zmagh)
write(fname,'("SFACMAG_",I1.1,".OUT")') idm
open(50,file=trim(fname),form='FORMATTED')
write(50,*)
write(50,'("h k l indices transformed by vhmat matrix:")')
write(50,'(3G18.10)') vhmat(:,1)
write(50,'(3G18.10)') vhmat(:,2)
write(50,'(3G18.10)') vhmat(:,3)
write(50,*)
write(50,'(" h k l multipl. |H| Re(F)&
& Im(F) |F|")')
write(50,*)
do ih=1,nhvec
! apply transformation matrix
v(:)=vhmat(:,1)*dble(ivh(1,ih)) &
+vhmat(:,2)*dble(ivh(2,ih)) &
+vhmat(:,3)*dble(ivh(3,ih))
! in crystallography the forward Fourier transform of real-space density is
! usually done with positive phase and without 1/omega prefactor
a=dble(zmagh(ih))*omega
b=-aimag(zmagh(ih))*omega
r=abs(zmagh(ih))*omega
iv(:)=nint(v(:))
if ((abs(v(1)-iv(1)).le.epslat).and. &
(abs(v(2)-iv(2)).le.epslat).and. &
(abs(v(3)-iv(3)).le.epslat)) then
! integer hkl
write(50,'(4I7,4G16.8)') iv(:),mulh(ih),hc(ih),a,b,r
else
! non-integer hkl
write(50,'(3F7.2,I7,4G16.8)') v(:),mulh(ih),hc(ih),a,b,r
end if
end do
close(50)
end do
write(*,*)
write(*,'("Info(sfacmag): magnetic structure factors written to &
&SFACMAG_j.OUT")')
write(*,'(" for magnetic components j = ",3I2)') (idm,idm=1,ndmag)
if (ndmag.eq.1) then
write(*,'(" (this corresponds to the z-component of the magnetisation)")')
end if
write(*,*)
write(*,'(" Energy window : ",2G18.10)') wsfac(:)
! write the structure factors to test file
call writetest(196,'magnetic structure factors',nv=nhvec,tol=1.d-4,zva=zmagh(:))
deallocate(zmagh)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/gradwfcr2.f90 0000644 0000000 0000000 00000000132 13543334734 015027 x ustar 00 30 mtime=1569569244.691641905
30 atime=1569569240.862644351
30 ctime=1569569244.691641905
elk-6.3.2/src/gradwfcr2.f90 0000644 0025044 0025044 00000002572 13543334734 017104 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 gradwfcr2(gwf2mt)
use modmain
implicit none
! arguments
real(8), intent(inout) :: gwf2mt(npmtmax,natmtot)
! local variables
integer ist,is,ias
integer nr,nri,iro,ir
integer np,l,m,lm,i
! allocatable arrays
complex(8), allocatable :: wfmt(:),gwfmt(:,:),zfmt(:)
allocate(wfmt(npmtmax),gwfmt(npmtmax,3),zfmt(npmtmax))
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
iro=nri+1
np=npmt(is)
do ist=1,nstsp(is)
if (spcore(ist,is).and.(ksp(ist,is).eq.lsp(ist,is)+1)) then
l=lsp(ist,is)
do m=-l,l
lm=idxlm(l,m)
wfmt(1:np)=0.d0
i=lm
do ir=1,nri
wfmt(i)=rwfcr(ir,1,ist,ias)/rsp(ir,is)
i=i+lmmaxi
end do
do ir=iro,nr
wfmt(i)=rwfcr(ir,1,ist,ias)/rsp(ir,is)
i=i+lmmaxo
end do
call gradzfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),wfmt,npmtmax,gwfmt)
do i=1,3
call zbsht(nr,nri,gwfmt(:,i),zfmt)
! factor of 2 from spin
gwf2mt(1:np,ias)=gwf2mt(1:np,ias) &
+2.d0*(dble(zfmt(1:np))**2+aimag(zfmt(1:np))**2)
end do
end do
end if
end do
! end loops over atoms
end do
deallocate(wfmt,gwfmt,zfmt)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/symrvfmt.f90 0000644 0000000 0000000 00000000132 13543334734 015035 x ustar 00 30 mtime=1569569244.695641903
30 atime=1569569240.868644347
30 ctime=1569569244.695641903
elk-6.3.2/src/symrvfmt.f90 0000644 0025044 0025044 00000007044 13543334734 017111 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 symrvfmt(tspin,tnc,nr,nri,np,ld,rvfmt)
use modmain
implicit none
! arguments
logical, intent(in) :: tspin,tnc
integer, intent(in) :: nr(nspecies),nri(nspecies),np(nspecies)
integer, intent(in) :: ld
real(8), intent(inout) :: rvfmt(ld,natmtot,*)
! local variables
integer is,ia,ja,ias,jas
integer nd,isym,lspl,lspn,i
real(8) sc(3,3),v1(3),v2(3),t0
! automatic arrays
logical done(natmmax)
! allocatable arrays
real(8), allocatable :: rvfmt1(:,:,:),rvfmt2(:,:)
! dimension of the vector field
if (tnc) then
nd=3
else
nd=1
end if
allocate(rvfmt1(npmtmax,natmmax,nd),rvfmt2(npmtmax,nd))
t0=1.d0/dble(nsymcrys)
do is=1,nspecies
! make copy of vector field for all atoms of current species
do i=1,nd
do ia=1,natoms(is)
ias=idxas(ia,is)
call dcopy(np(is),rvfmt(:,ias,i),1,rvfmt1(:,ia,i),1)
end do
end do
done(:)=.false.
do ia=1,natoms(is)
if (done(ia)) cycle
ias=idxas(ia,is)
rvfmt(1:np(is),ias,1:nd)=0.d0
! begin loop over crystal symmetries
do isym=1,nsymcrys
! equivalent atom
ja=ieqatom(ia,is,isym)
! parallel transport of vector field
lspl=lsplsymc(isym)
do i=1,nd
call rotrfmt(symlatc(:,:,lspl),nr(is),nri(is),rvfmt1(:,ja,i), &
rvfmt2(:,i))
end do
if (tspin) then
! global spin proper rotation matrix in Cartesian coordinates
lspn=lspnsymc(isym)
sc(:,:)=symlatd(lspn)*symlatc(:,:,lspn)
else
! set spin rotation equal to spatial rotation
lspn=lspl
sc(:,:)=symlatc(:,:,lspl)
end if
! global spin rotation of vector field
if (tnc) then
! non-collinear case
do i=1,np(is)
v1(:)=rvfmt2(i,:)
v2(1)=sc(1,1)*v1(1)+sc(1,2)*v1(2)+sc(1,3)*v1(3)
v2(2)=sc(2,1)*v1(1)+sc(2,2)*v1(2)+sc(2,3)*v1(3)
v2(3)=sc(3,1)*v1(1)+sc(3,2)*v1(2)+sc(3,3)*v1(3)
rvfmt(i,ias,1:3)=rvfmt(i,ias,1:3)+v2(1:3)
end do
else
! collinear case
call daxpy(np(is),sc(3,3),rvfmt2,1,rvfmt(:,ias,1),1)
end if
! end loop over crystal symmetries
end do
! normalise
do i=1,nd
call dscal(np(is),t0,rvfmt(:,ias,i),1)
end do
! mark atom as done
done(ia)=.true.
! rotate into equivalent atoms
do isym=1,nsymcrys
ja=ieqatom(ia,is,isym)
if (done(ja)) cycle
jas=idxas(ja,is)
! parallel transport of vector field (using operation inverse)
lspl=isymlat(lsplsymc(isym))
do i=1,nd
call rotrfmt(symlatc(:,:,lspl),nr(is),nri(is),rvfmt(:,ias,i), &
rvfmt(:,jas,i))
end do
if (tspin) then
! inverse of global proper rotation matrix in Cartesian coordinates
lspn=isymlat(lspnsymc(isym))
sc(:,:)=symlatd(lspn)*symlatc(:,:,lspn)
else
! set spin rotation equal to spatial rotation
lspn=lspl
sc(:,:)=symlatc(:,:,lspl)
end if
! global spin rotation of vector field
if (tnc) then
! non-collinear case
do i=1,np(is)
v1(1:3)=rvfmt(i,jas,1:3)
v2(1)=sc(1,1)*v1(1)+sc(1,2)*v1(2)+sc(1,3)*v1(3)
v2(2)=sc(2,1)*v1(1)+sc(2,2)*v1(2)+sc(2,3)*v1(3)
v2(3)=sc(3,1)*v1(1)+sc(3,2)*v1(2)+sc(3,3)*v1(3)
rvfmt(i,jas,1:3)=v2(1:3)
end do
else
! collinear case
call dscal(np(is),sc(3,3),rvfmt(:,jas,1),1)
end if
! mark atom as done
done(ja)=.true.
end do
! end loop over atoms and species
end do
end do
deallocate(rvfmt1,rvfmt2)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/oepmain.f90 0000644 0000000 0000000 00000000126 13543334734 014601 x ustar 00 28 mtime=1569569244.7006419
30 atime=1569569240.873644344
28 ctime=1569569244.7006419
elk-6.3.2/src/oepmain.f90 0000644 0025044 0025044 00000012702 13543334734 016647 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 oepmain
use modmain
use modmpi
use modomp
implicit none
! local variables
integer ik,idm,is,ias
integer nrc,nrci,np,npc
integer n,nthd,it
real(8) t1
! allocatable arrays
real(8), allocatable :: dvxmt(:,:),dvxir(:)
real(8), allocatable :: dbxmt(:,:,:),dbxir(:,:)
real(8), allocatable :: rfmt1(:,:),rfmt2(:),rfir(:)
real(8), allocatable :: rvfmt(:,:,:),rvfir(:,:)
complex(8), allocatable :: vclcv(:,:,:,:),vclvv(:,:,:)
! external functions
real(8) rfinpc
external rfinpc
! initialise the OEP exchange potential
if (iscl.le.0) then
call initoep
return
end if
! calculate Coulomb matrix elements
allocate(vclcv(ncrmax,natmtot,nstsv,nkpt),vclvv(nstsv,nstsv,nkpt))
call oepvcl(vclcv,vclvv)
! allocate local arrays
allocate(dvxmt(npcmtmax,natmtot),dvxir(ngtot))
allocate(rfmt1(npmtmax,natmtot),rfir(ngtot))
if (spinpol) then
allocate(dbxmt(npcmtmax,natmtot,ndmag),dbxir(ngtot,ndmag))
allocate(rvfmt(npmtmax,natmtot,ndmag),rvfir(ngtot,ndmag))
end if
!------------------------------!
! start iteration loop !
!------------------------------!
do it=1,maxitoep
if (mp_mpi.and.(mod(it,10).eq.0)) then
write(*,'("Info(oepmain): done ",I4," iterations of ",I4)') it,maxitoep
end if
! zero the residuals
dvxmt(:,:)=0.d0
dvxir(:)=0.d0
if (spinpol) then
dbxmt(:,:,:)=0.d0
dbxir(:,:)=0.d0
end if
! calculate the k-dependent residuals
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
call oepresk(ik,vclcv,vclvv,dvxmt,dvxir,dbxmt,dbxir)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! add residuals from each process and redistribute
if (np_mpi.gt.1) then
n=npcmtmax*natmtot
call mpi_allreduce(mpi_in_place,dvxmt,n,mpi_double_precision,mpi_sum, &
mpicom,ierror)
call mpi_allreduce(mpi_in_place,dvxir,ngtot,mpi_double_precision, &
mpi_sum,mpicom,ierror)
if (spinpol) then
n=n*ndmag
call mpi_allreduce(mpi_in_place,dbxmt,n,mpi_double_precision,mpi_sum, &
mpicom,ierror)
n=ngtot*ndmag
call mpi_allreduce(mpi_in_place,dbxir,n,mpi_double_precision,mpi_sum, &
mpicom,ierror)
end if
end if
! convert muffin-tin residuals to spherical harmonics
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(is,nrc,nrci,idm) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
call rfsht(nrc,nrci,dvxmt(:,ias),rfmt1(:,ias))
do idm=1,ndmag
call rfsht(nrc,nrci,dbxmt(:,ias,idm),rvfmt(:,ias,idm))
end do
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! symmetrise the residuals
call symrf(nrcmt,nrcmti,npcmt,npmtmax,rfmt1,dvxir)
if (spinpol) call symrvf(.true.,ncmag,nrcmt,nrcmti,npcmt,npmtmax,rvfmt,dbxir)
! magnitude of residuals
resoep=sqrt(abs(rfinpc(npmtmax,rfmt1,dvxir,rfmt1,dvxir)))
do idm=1,ndmag
t1=rfinpc(npmtmax,rvfmt(:,:,idm),dbxir(:,idm),rvfmt(:,:,idm),dbxir(:,idm))
resoep=resoep+sqrt(abs(t1))
end do
resoep=resoep/omega
! update exchange potential and magnetic field
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(rfmt2,is,nrc,nrci,npc,idm) &
!$OMP NUM_THREADS(nthd)
allocate(rfmt2(npcmtmax))
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
! convert residual to spherical coordinates
call rbsht(nrc,nrci,rfmt1(:,ias),rfmt2)
! subtract from exchange potential
vxmt(1:npc,ias)=vxmt(1:npc,ias)-tauoep*rfmt2(1:npc)
! repeat for exchange magnetic field
do idm=1,ndmag
call rbsht(nrc,nrci,rvfmt(:,ias,idm),rfmt2)
bxmt(1:npc,ias,idm)=bxmt(1:npc,ias,idm)-tauoep*rfmt2(1:npc)
end do
end do
!$OMP END DO
deallocate(rfmt2)
!$OMP END PARALLEL
call freethd(nthd)
vxir(:)=vxir(:)-tauoep*dvxir(:)
do idm=1,ndmag
bxir(:,idm)=bxir(:,idm)-tauoep*dbxir(:,idm)
end do
! end iteration loop
end do
! convert the exchange potential and field to spherical harmonics
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(is,nrc,nrci,idm) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
call rfsht(nrc,nrci,vxmt(:,ias),rfmt1(:,ias))
do idm=1,ndmag
call rfsht(nrc,nrci,bxmt(:,ias,idm),rvfmt(:,ias,idm))
end do
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! convert potential and field from a coarse to a fine radial mesh
call rfmtctof(rfmt1)
do idm=1,ndmag
call rfmtctof(rvfmt(:,:,idm))
end do
! add to existing (density derived) correlation potential and field
do ias=1,natmtot
is=idxis(ias)
np=npmt(is)
vxcmt(1:np,ias)=vxcmt(1:np,ias)+rfmt1(1:np,ias)
do idm=1,ndmag
bxcmt(1:np,ias,idm)=bxcmt(1:np,ias,idm)+rvfmt(1:np,ias,idm)
end do
end do
vxcir(:)=vxcir(:)+vxir(:)
do idm=1,ndmag
bxcir(:,idm)=bxcir(:,idm)+bxir(:,idm)
end do
! symmetrise the exchange potential and field
call symrf(nrmt,nrmti,npmt,npmtmax,vxcmt,vxcir)
if (spinpol) call symrvf(.true.,ncmag,nrmt,nrmti,npmt,npmtmax,bxcmt,bxcir)
deallocate(rfmt1,rfir,vclcv,vclvv)
deallocate(dvxmt,dvxir)
if (spinpol) then
deallocate(rvfmt,rvfir)
deallocate(dbxmt,dbxir)
end if
! set the constant part of the exchange potential equal to that of LDA/GGA
call rfint0(vxc0,vxcmt,vxcir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/oepresk.f90 0000644 0000000 0000000 00000000132 13543334734 014616 x ustar 00 30 mtime=1569569244.705641896
30 atime=1569569240.878644341
30 ctime=1569569244.705641896
elk-6.3.2/src/oepresk.f90 0000644 0025044 0025044 00000014070 13543334734 016667 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 oepresk(ik,vclcv,vclvv,dvxmt,dvxir,dbxmt,dbxir)
use modmain
implicit none
! arguments
integer, intent(in) :: ik
complex(8), intent(in) :: vclcv(ncrmax,natmtot,nstsv,nkpt)
complex(8), intent(in) :: vclvv(nstsv,nstsv,nkpt)
real(8), intent(inout) :: dvxmt(npcmtmax,natmtot),dvxir(ngtot)
real(8), intent(inout) :: dbxmt(npcmtmax,natmtot,ndmag),dbxir(ngtot,ndmag)
! local variables
integer ist,jst,idm
integer is,ia,ias,ic,m
integer nrc,nrci,npc
real(8) de
complex(8) z1,z2
! automatic arrays
integer idx(nstsv)
! allocatable arrays
complex(8), allocatable :: apwalm(:,:,:,:),evecfv(:,:),evecsv(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfir(:,:,:),wfcr(:,:)
complex(8), allocatable :: zfmt1(:),zvfmt1(:,:)
complex(8), allocatable :: zfmt2(:,:),zfir2(:)
complex(8), allocatable :: zvfmt2(:,:,:),zvfir2(:,:)
! external functions
complex(8) rzfinp,rzfmtinp
external rzfinp,rzfmtinp
! get the eigenvalues/vectors from file for input k-point
allocate(evecfv(nmatmax,nstfv),evecsv(nstsv,nstsv))
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! find the matching coefficients
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot))
call match(ngk(1,ik),vgkc(:,:,1,ik),gkc(:,1,ik),sfacgk(:,:,1,ik),apwalm)
! index to all states
do ist=1,nstsv
idx(ist)=ist
end do
! calculate the wavefunctions for all states
allocate(wfmt(npcmtmax,natmtot,nspinor,nstsv),wfir(ngtot,nspinor,nstsv))
call genwfsv(.false.,.false.,nstsv,idx,ngridg,igfft,ngk(1,ik),igkig(:,1,ik), &
apwalm,evecfv,evecsv,wfmt,ngtot,wfir)
deallocate(apwalm,evecfv,evecsv)
!-----------------------------------------------------------!
! core-conduction overlap density and magnetisation !
!-----------------------------------------------------------!
allocate(wfcr(npcmtmax,2),zfmt1(npcmtmax))
if (spinpol) allocate(zvfmt1(npcmtmax,ndmag))
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
ic=0
do ist=1,nstsp(is)
if (spcore(ist,is)) then
do m=-ksp(ist,is),ksp(ist,is)-1
ic=ic+1
! pass in m-1/2 to wavefcr
call wavefcr(.false.,lradstp,is,ia,ist,m,npcmtmax,wfcr)
do jst=1,nstsv
if (evalsv(jst,ik).gt.efermi) then
if (spinpol) then
! compute the complex density and magnetisation
call genzrm(npc,wfcr,wfcr(:,2),wfmt(:,ias,1,jst), &
wfmt(:,ias,2,jst),zfmt1,npcmtmax,zvfmt1)
else
! compute the complex density
zfmt1(1:npc)=conjg(wfcr(1:npc,1))*wfmt(1:npc,ias,1,jst)
end if
z1=conjg(vclcv(ic,ias,jst,ik))
z2=rzfmtinp(nrc,nrci,wrcmt(:,is),vxmt(:,ias),zfmt1)
z1=z1-conjg(z2)
do idm=1,ndmag
z2=rzfmtinp(nrc,nrci,wrcmt(:,is),bxmt(:,ias,idm),zvfmt1(:,idm))
z1=z1-conjg(z2)
end do
de=evalcr(ist,ias)-evalsv(jst,ik)
z1=z1*occmax*wkpt(ik)/(de+zi*swidth)
! residuals for exchange potential and field
!$OMP CRITICAL(oepresk_)
call rzadd(npc,z1,zfmt1,dvxmt(:,ias))
do idm=1,ndmag
call rzadd(npc,z1,zvfmt1(:,idm),dbxmt(:,ias,idm))
end do
!$OMP END CRITICAL(oepresk_)
! end loop over jst
end if
end do
end do
! end loop over ist
end if
end do
! end loops over atoms and species
end do
end do
deallocate(wfcr,zfmt1)
if (spinpol) deallocate(zvfmt1)
!--------------------------------------------------------------!
! valence-conduction overlap density and magnetisation !
!--------------------------------------------------------------!
allocate(zfmt2(npcmtmax,natmtot),zfir2(ngtot))
if (spinpol) then
allocate(zvfmt2(npcmtmax,natmtot,ndmag),zvfir2(ngtot,ndmag))
end if
do ist=1,nstsv
if (evalsv(ist,ik).lt.efermi) then
do jst=1,nstsv
if (evalsv(jst,ik).gt.efermi) then
if (spinpol) then
! compute the complex density and magnetisation
call genzfrm(wfmt(:,:,1,ist),wfmt(:,:,2,ist),wfir(:,1,ist), &
wfir(:,2,ist),wfmt(:,:,1,jst),wfmt(:,:,2,jst),wfir(:,1,jst), &
wfir(:,2,jst),zfmt2,zfir2,zvfmt2,zvfir2)
else
! compute the complex density
call genzrho(.false.,.true.,ngtot,wfmt(:,:,:,ist),wfir(:,:,ist), &
wfmt(:,:,:,jst),wfir(:,:,jst),zfmt2,zfir2)
end if
z1=conjg(vclvv(ist,jst,ik))
z2=rzfinp(vxmt,vxir,zfmt2,zfir2)
z1=z1-conjg(z2)
do idm=1,ndmag
z2=rzfinp(bxmt(:,:,idm),bxir(:,idm),zvfmt2(:,:,idm),zvfir2(:,idm))
z1=z1-conjg(z2)
end do
de=evalsv(ist,ik)-evalsv(jst,ik)
z1=z1*occmax*wkpt(ik)/(de+zi*swidth)
! add to residuals for exchange potential and field
!$OMP CRITICAL(oepresk_)
call rzfadd(z1,zfmt2,zfir2,dvxmt,dvxir)
do idm=1,ndmag
call rzfadd(z1,zvfmt2(:,:,idm),zvfir2(:,idm),dbxmt(:,:,idm), &
dbxir(:,idm))
end do
!$OMP END CRITICAL(oepresk_)
! end loop over jst
end if
end do
! end loop over ist
end if
end do
deallocate(wfmt,wfir,zfmt2,zfir2)
if (spinpol) deallocate(zvfmt2,zvfir2)
return
end subroutine
subroutine rzadd(n,za,zv,rv)
implicit none
! arguments
integer, intent(in) :: n
complex(8), intent(in) :: za
real(8), intent(in) :: zv(2*n)
real(8), intent(out) :: rv(n)
! local variables
real(8) t1
t1=dble(za)
if (abs(t1).gt.1.d-12) call daxpy(n,t1,zv,2,rv,1)
t1=-aimag(za)
if (abs(t1).gt.1.d-12) call daxpy(n,t1,zv(2),2,rv,1)
return
end subroutine
subroutine rzfadd(za,zfmt,zfir,rfmt,rfir)
use modmain
implicit none
! arguments
complex(8), intent(in) :: za
complex(8), intent(in) :: zfmt(npcmtmax,natmtot),zfir(ngtot)
real(8), intent(inout) :: rfmt(npcmtmax,natmtot),rfir(ngtot)
! local variables
integer is,ias
do ias=1,natmtot
is=idxis(ias)
call rzadd(npcmt(is),za,zfmt(:,ias),rfmt(:,ias))
end do
call rzadd(ngtot,za,zfir,rfir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/oepvcl.f90 0000644 0000000 0000000 00000000132 13543334734 014436 x ustar 00 30 mtime=1569569244.709641894
30 atime=1569569240.883644337
30 ctime=1569569244.709641894
elk-6.3.2/src/oepvcl.f90 0000644 0025044 0025044 00000002214 13543334734 016504 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.
subroutine oepvcl(vclcv,vclvv)
use modmain
use modmpi
use modomp
implicit none
! arguments
complex(8), intent(out) :: vclcv(ncrmax,natmtot,nstsv,nkpt)
complex(8), intent(out) :: vclvv(nstsv,nstsv,nkpt)
! local variables
integer ik,ncv,nvv
integer lp,nthd
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
!$OMP CRITICAL(oepvcl_)
write(*,'("Info(oepvcl): ",I6," of ",I6," k-points")') ik,nkpt
!$OMP END CRITICAL(oepvcl_)
call oepvclk(ik,vclcv(:,:,:,ik),vclvv(:,:,ik))
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! broadcast matrix elements to all other processes
ncv=ncrmax*natmtot*nstsv
nvv=nstsv*nstsv
do ik=1,nkpt
lp=mod(ik-1,np_mpi)
call mpi_bcast(vclcv(:,:,:,ik),ncv,mpi_double_complex,lp,mpicom,ierror)
call mpi_bcast(vclvv(:,:,ik),nvv,mpi_double_complex,lp,mpicom,ierror)
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/oepvclk.f90 0000644 0000000 0000000 00000000132 13543334734 014611 x ustar 00 30 mtime=1569569244.714641891
30 atime=1569569240.889644334
30 ctime=1569569244.714641891
elk-6.3.2/src/oepvclk.f90 0000644 0025044 0025044 00000023366 13543334734 016672 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 oepvclk(ikp,vclcv,vclvv)
use modmain
implicit none
! arguments
integer, intent(in) :: ikp
complex(8), intent(out) :: vclcv(ncrmax,natmtot,nstsv)
complex(8), intent(out) :: vclvv(nstsv,nstsv)
! local variables
integer ik,jk,nst,ist1,ist2,ist3
integer is,ia,ias,nrc,nrci,npc
integer iv(3),ig,iq,i
integer ic,jc,m1,m2
real(8) vc(3)
complex(8) z1
! automatic arrays
integer idx(nstsv)
! allocatable arrays
real(8), allocatable :: vgqc(:,:),gqc(:),gclgq(:),jlgqrmt(:,:,:)
complex(8), allocatable :: apwalm(:,:,:,:),evecfv(:,:),evecsv(:,:)
complex(8), allocatable :: ylmgq(:,:),sfacgq(:,:)
complex(8), allocatable :: wfmt1(:,:,:,:),wfmt2(:,:,:,:)
complex(8), allocatable :: wfir1(:,:,:),wfir2(:,:,:)
complex(8), allocatable :: wfcr1(:,:),wfcr2(:,:)
complex(8), allocatable :: zrhomt1(:,:,:),zrhomt2(:,:),zrhoir1(:,:)
complex(8), allocatable :: zvclmt(:,:),zvclir(:),zfmt(:)
! external functions
complex(8) zfinp,zfmtinp
external zfinp,zfmtinp
! allocate local arrays
allocate(vgqc(3,ngvc),gqc(ngvc),gclgq(ngvc))
allocate(jlgqrmt(0:lnpsd,ngvc,nspecies))
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot))
allocate(evecfv(nmatmax,nstfv),evecsv(nstsv,nstsv))
allocate(ylmgq(lmmaxo,ngvc),sfacgq(ngvc,natmtot))
allocate(wfmt1(npcmtmax,natmtot,nspinor,nstsv))
allocate(wfmt2(npcmtmax,natmtot,nspinor,nstsv))
allocate(wfir1(ngtc,nspinor,nstsv),wfir2(ngtc,nspinor,nstsv))
allocate(wfcr1(npcmtmax,2),wfcr2(npcmtmax,2))
allocate(zrhomt1(npcmtmax,natmtot,nstsv),zrhoir1(ngtc,nstsv))
allocate(zrhomt2(npcmtmax,nstcr),zfmt(npcmtmax))
allocate(zvclmt(npcmtmax,natmtot),zvclir(ngtc))
! zero the Coulomb matrix elements
vclcv(:,:,:)=0.d0
vclvv(:,:)=0.d0
! get the eigenvectors from file for input reduced k-point
call getevecfv(filext,ikp,vkl(:,ikp),vgkl(:,:,:,ikp),evecfv)
call getevecsv(filext,ikp,vkl(:,ikp),evecsv)
! find the matching coefficients
call match(ngk(1,ikp),vgkc(:,:,1,ikp),gkc(:,1,ikp),sfacgk(:,:,1,ikp),apwalm)
! index to all states
do ist1=1,nstsv
idx(ist1)=ist1
end do
! calculate the wavefunctions for all states of the input k-point
call genwfsv(.false.,.false.,nstsv,idx,ngdc,igfc,ngk(1,ikp),igkig(:,1,ikp), &
apwalm,evecfv,evecsv,wfmt1,ngtc,wfir1)
! loop over non-reduced k-point set
do ik=1,nkptnr
! equivalent reduced k-point
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
! determine q-vector
iv(:)=ivk(:,ikp)-ivk(:,ik)
iv(:)=modulo(iv(:),ngridk(:))
! check if the q-point is in user-defined set
iv(:)=iv(:)*ngridq(:)
do i=1,3
if (modulo(iv(i),ngridk(i)).ne.0) goto 10
end do
iv(:)=iv(:)/ngridk(:)
iq=iqmap(iv(1),iv(2),iv(3))
vc(:)=vkc(:,ikp)-vkc(:,ik)
do ig=1,ngvc
! determine the G+q-vectors
vgqc(:,ig)=vgc(:,ig)+vc(:)
! G+q-vector length
gqc(ig)=sqrt(vgqc(1,ig)**2+vgqc(2,ig)**2+vgqc(3,ig)**2)
! spherical harmonics for G+q-vectors
call genylmv(lmaxo,vgqc(:,ig),ylmgq(:,ig))
end do
! structure factors for G+q
call gensfacgp(ngvc,vgqc,ngvc,sfacgq)
! generate the regularised Coulomb Green's function in G+q-space
call gengclgq(.true.,iq,ngvc,gqc,gclgq)
! compute the required spherical Bessel functions
call genjlgprmt(lnpsd,ngvc,gqc,ngvc,jlgqrmt)
! find the matching coefficients
call match(ngk(1,ik),vgkc(:,:,1,ik),gkc(:,1,ik),sfacgk(:,:,1,ik),apwalm)
! get the eigenvectors from file for non-reduced k-points
call getevecfv(filext,0,vkl(:,ik),vgkl(:,:,1,ik),evecfv)
call getevecsv(filext,0,vkl(:,ik),evecsv)
! count and index occupied states
nst=0
do ist3=1,nstsv
if (evalsv(ist3,jk).lt.efermi) then
nst=nst+1
idx(nst)=ist3
end if
end do
! calculate the wavefunctions for occupied states
call genwfsv(.false.,.false.,nst,idx,ngdc,igfc,ngk(1,ik),igkig(:,1,ik), &
apwalm,evecfv,evecsv,wfmt2,ngtc,wfir2)
do ist3=1,nst
! compute the complex overlap densities for all valence-valence states
do ist1=1,nstsv
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,ist3),wfir2(:,:,ist3), &
wfmt1(:,:,:,ist1),wfir1(:,:,ist1),zrhomt1(:,:,ist1),zrhoir1(:,ist1))
end do
! compute the complex overlap densities for all valence-core states
jc=0
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
do ist1=1,nstsp(is)
if (spcore(ist1,is)) then
do m1=-ksp(ist1,is),ksp(ist1,is)-1
jc=jc+1
! generate the core wavefunction in spherical coordinates (pass in m-1/2)
call wavefcr(.false.,lradstp,is,ia,ist1,m1,npcmtmax,wfcr1)
if (spinpol) then
call zrho2(npc,wfmt2(:,ias,1,ist3),wfmt2(:,ias,2,ist3),wfcr1, &
wfcr1(:,2),zfmt)
else
call zrho1(npc,wfmt2(:,ias,1,ist3),wfcr1,zfmt)
end if
! convert to spherical harmonics
call zfsht(nrc,nrci,zfmt,zrhomt2(:,jc))
end do
end if
end do
end do
end do
do ist2=1,nstsv
if (evalsv(ist2,ikp).gt.efermi) then
! calculate the Coulomb potential
call genzvclmt(nrcmt,nrcmti,nrcmtmax,rlcmt,wprcmt,npcmtmax, &
zrhomt1(:,:,ist2),zvclmt)
call zpotcoul(nrcmt,nrcmti,npcmt,npcmti,nrcmtmax,rlcmt,ngdc,igfc,ngvc, &
gqc,gclgq,ngvc,jlgqrmt,ylmgq,sfacgq,zrhoir1(:,ist2),npcmtmax,zvclmt, &
zvclir)
!----------------------------------------------!
! valence-valence-valence contribution !
!----------------------------------------------!
do ist1=1,nstsv
if (evalsv(ist1,ikp).lt.efermi) then
z1=zfinp(zrhomt1(:,:,ist1),zrhoir1(:,ist1),zvclmt,zvclir)
vclvv(ist1,ist2)=vclvv(ist1,ist2)-wqptnr*z1
end if
end do
!-------------------------------------------!
! core-valence-valence contribution !
!-------------------------------------------!
jc=0
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
ic=0
do ist1=1,nstsp(is)
if (spcore(ist1,is)) then
do m1=-ksp(ist1,is),ksp(ist1,is)-1
ic=ic+1
jc=jc+1
z1=zfmtinp(nrc,nrci,wrcmt(:,is),zrhomt2(:,jc),zvclmt(:,ias))
vclcv(ic,ias,ist2)=vclcv(ic,ias,ist2)-wqptnr*z1
end do
! end loop over ist1
end if
end do
! end loops over atoms and species
end do
end do
! end loop over ist2
end if
end do
! end loop over ist3
end do
10 continue
! end loop over non-reduced k-point set
end do
! begin loops over atoms and species
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
do ist3=1,nstsp(is)
if (spcore(ist3,is)) then
do m1=-ksp(ist3,is),ksp(ist3,is)-1
! generate the core wavefunction in spherical coordinates (pass in m-1/2)
call wavefcr(.false.,lradstp,is,ia,ist3,m1,npcmtmax,wfcr1)
! compute the complex overlap densities for the core-valence states
do ist1=1,nstsv
if (spinpol) then
call zrho2(npc,wfcr1,wfcr1(:,2),wfmt1(:,ias,1,ist1), &
wfmt1(:,ias,2,ist1),zfmt)
else
call zrho1(npc,wfcr1,wfmt1(:,ias,1,ist1),zfmt)
end if
call zfsht(nrc,nrci,zfmt,zrhomt1(:,ias,ist1))
end do
! compute the complex overlap densities for the core-core states
ic=0
do ist1=1,nstsp(is)
if (spcore(ist1,is)) then
do m2=-ksp(ist1,is),ksp(ist1,is)-1
ic=ic+1
call wavefcr(.false.,lradstp,is,ia,ist1,m2,npcmtmax,wfcr2)
call zrho2(npc,wfcr1,wfcr1(:,2),wfcr2,wfcr2(:,2),zfmt)
call zfsht(nrc,nrci,zfmt,zrhomt2(:,ic))
end do
end if
end do
do ist2=1,nstsv
if (evalsv(ist2,ikp).gt.efermi) then
! calculate the Coulomb potential
call zpotclmt(nrc,nrci,nrcmtmax,rlcmt(:,:,is),wprcmt(:,:,is), &
zrhomt1(:,ias,ist2),zvclmt)
!-------------------------------------------!
! valence-core-valence contribution !
!-------------------------------------------!
do ist1=1,nstsv
if (evalsv(ist1,ikp).lt.efermi) then
z1=zfmtinp(nrc,nrci,wrcmt(:,is),zrhomt1(:,ias,ist1),zvclmt)
vclvv(ist1,ist2)=vclvv(ist1,ist2)-z1
end if
end do
!----------------------------------------!
! core-core-valence contribution !
!----------------------------------------!
ic=0
do ist1=1,nstsp(is)
if (spcore(ist1,is)) then
do m2=-ksp(ist1,is),ksp(ist1,is)-1
ic=ic+1
z1=zfmtinp(nrc,nrci,wrcmt(:,is),zrhomt2(:,ic),zvclmt)
vclcv(ic,ias,ist2)=vclcv(ic,ias,ist2)-z1
end do
! end loop over ist1
end if
end do
! end loop over ist2
end if
end do
! end loops over ist3 and m1
end do
end if
end do
! end loops over atoms and species
end do
end do
deallocate(vgqc,gqc,gclgq,jlgqrmt)
deallocate(apwalm,evecfv,evecsv,ylmgq,sfacgq)
deallocate(wfmt1,wfmt2,wfir1,wfir2,wfcr1,wfcr2)
deallocate(zrhomt1,zrhomt2,zrhoir1)
deallocate(zvclmt,zvclir,zfmt)
return
contains
subroutine zrho1(n,x,y,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x(n),y(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x(:))*y(:)
return
end subroutine
subroutine zrho2(n,x1,x2,y1,y2,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x1(n),x2(n),y1(n),y2(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x1(:))*y1(:)+conjg(x2(:))*y2(:)
return
end subroutine
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/dbxcplot.f90 0000644 0000000 0000000 00000000131 13543334734 014764 x ustar 00 30 mtime=1569569244.718641888
29 atime=1569569240.89464433
30 ctime=1569569244.718641888
elk-6.3.2/src/dbxcplot.f90 0000644 0025044 0025044 00000004170 13543334734 017036 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 dbxcplot
use modmain
implicit none
! local variables
integer idm,is,ias,np
! allocatable arrays
real(8), allocatable :: rvfmt(:,:,:),rvfir(:,:)
real(8), allocatable :: rfmt(:,:),rfir(:)
real(8), allocatable :: grfmt(:,:,:),grfir(:,:)
! initialise universal variables
call init0
if (.not.spinpol) then
write(*,*)
write(*,'("Error(dbxcplot): spin-unpolarised magnetic field is zero")')
write(*,*)
stop
end if
! read magnetisation from file
call readstate
allocate(rvfmt(npmtmax,natmtot,3),rvfir(ngtot,3))
allocate(rfmt(npmtmax,natmtot),rfir(ngtot))
allocate(grfmt(npmtmax,natmtot,3),grfir(ngtot,3))
if (ncmag) then
! non-collinear
rvfmt(:,:,:)=bxcmt(:,:,:)
rvfir(:,:)=bxcir(:,:)
else
! collinear
rvfmt(:,:,1:2)=0.d0
rvfir(:,1:2)=0.d0
rvfmt(:,:,3)=bxcmt(:,:,1)
rvfir(:,3)=bxcir(:,1)
end if
rfmt(:,:)=0.d0
rfir(:)=0.d0
do idm=1,3
call gradrf(rvfmt(:,:,idm),rvfir(:,idm),grfmt,grfir)
do ias=1,natmtot
is=idxis(ias)
np=npmt(is)
rfmt(1:np,ias)=rfmt(1:np,ias)+grfmt(1:np,ias,idm)
end do
rfir(:)=rfir(:)+grfir(:,idm)
end do
select case(task)
case(91)
open(50,file='DBXC1D.OUT',form='FORMATTED')
open(51,file='DBXCLINES.OUT',form='FORMATTED')
call plot1d(50,51,1,rfmt,rfir)
close(50)
close(51)
write(*,*)
write(*,'("Info(dbxcplot):")')
write(*,'(" 1D divergence of exchange-correlation field written to &
&DBXC1D.OUT")')
write(*,'(" vertex location lines written to DBXCLINES.OUT")')
case(92)
open(50,file='DBXC2D.OUT',form='FORMATTED')
call plot2d(.false.,50,1,rfmt,rfir)
close(50)
write(*,'("Info(dbxcplot):")')
write(*,'(" 2D divergence of exchange-correlation field written to &
&DBXC2D.OUT")')
case(93)
open(50,file='DBXC3D.OUT',form='FORMATTED')
call plot3d(50,1,rfmt,rfir)
close(50)
write(*,'("Info(dbxcplot):")')
write(*,'(" 3D divergence of exchange-correlation field written to &
&DBXC3D.OUT")')
end select
deallocate(rvfmt,rvfir,rfmt,rfir,grfmt,grfir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writehmlbse.f90 0000644 0000000 0000000 00000000132 13543334734 015473 x ustar 00 30 mtime=1569569244.722641885
30 atime=1569569240.900644327
30 ctime=1569569244.722641885
elk-6.3.2/src/writehmlbse.f90 0000644 0025044 0025044 00000004766 13543334734 017557 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine writehmlbse
use modmain
use modmpi
! sets up the BSE matrix and writes it to file
implicit none
! local variables
integer ik,jk,a,b
integer ist,jst,i,j
real(8) t1
! initialise global variables
call init0
call init1
call init2
call init3
! read density and potentials from file
call readstate
! read Fermi energy from a file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! get the eigenvalues and occupancies from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! check if system is metallic
t1=minval(abs(0.5d0-occsv(:,:)/occmax))
if (abs(t1-0.5d0).gt.0.01d0) then
write(*,*)
write(*,'("Warning(writehmlbse): system is metallic, the BSE may fail")')
write(*,'("Try using a different vkloff or reducing swidth")')
end if
! generate the BSE state index arrays
call genidxbse
if (allocated(hmlbse)) deallocate(hmlbse)
allocate(hmlbse(nmbse,nmbse))
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
if (mp_mpi) then
write(*,*)
write(*,'("Info(writehmlbse): setting up BSE Hamiltonian matrix")')
end if
! zero the BSE Hamiltonian
hmlbse(:,:)=0.d0
! compute diagonal matrix elements
do ik=1,nkptnr
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
do i=1,nvbse
ist=istbse(i,ik)
do j=1,ncbse
jst=jstbse(j,ik)
a=ijkbse(i,j,ik)
hmlbse(a,a)=(evalsv(jst,jk)+scissor)-evalsv(ist,jk)
if (bsefull) then
b=a+nbbse
hmlbse(b,b)=-hmlbse(a,a)
end if
end do
end do
end do
! add the exchange matrix elements
if (hxbse) call hmlxbse
! add the direct matrix elements
if (hdbse) call hmldbse
! add matrices from all processes and redistribute
if (np_mpi.gt.1) then
call mpi_allreduce(mpi_in_place,hmlbse,nmbse*nmbse,mpi_double_complex, &
mpi_sum,mpicom,ierror)
end if
! write the BSE matrix to HMLBSE.OUT
if (mp_mpi) then
open(50,file='HMLBSE.OUT',form='UNFORMATTED')
write(50) nmbse
write(50) hmlbse
close(50)
write(*,*)
write(*,'("Info(writehmlbse): BSE Hamiltonian matrix written to HMLBSE.OUT")')
end if
! deallocate global BSE arrays
deallocate(istbse,jstbse,ijkbse,hmlbse)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmldbse.f90 0000644 0000000 0000000 00000000132 13543334734 014564 x ustar 00 30 mtime=1569569244.726641883
30 atime=1569569240.905644323
30 ctime=1569569244.726641883
elk-6.3.2/src/hmldbse.f90 0000644 0025044 0025044 00000001303 13543334734 016630 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine hmldbse
use modmain
use modmpi
use modomp
implicit none
! local variables
integer ik2,nthd
call holdthd(nkptnr/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik2=1,nkptnr
! distribute among MPI processes
if (mod(ik2-1,np_mpi).ne.lp_mpi) cycle
!$OMP CRITICAL(hmldbse_)
write(*,'("Info(hmldbse): ",I6," of ",I6," k-points")') ik2,nkptnr
!$OMP END CRITICAL(hmldbse_)
call hmldbsek(ik2)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmldbsek.f90 0000644 0000000 0000000 00000000127 13543334734 014743 x ustar 00 29 mtime=1569569244.73164188
29 atime=1569569240.91064432
29 ctime=1569569244.73164188
elk-6.3.2/src/hmldbsek.f90 0000644 0025044 0025044 00000014347 13543334734 017017 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine hmldbsek(ik2)
use modmain
use modomp
implicit none
! arguments
integer, intent(in) :: ik2
! local variables
integer ik1,ist1,ist2,jst1,jst2
integer i1,i2,j1,j2,a1,a2,b1,b2
integer iv(3),iq,ig,jg,nthd
real(8) vl(3),vc(3),t0,t1,t2
complex(8) z1
! automatic arrays
integer idx(nstsv),ngp(nspnfv)
! allocatable arrays
integer, allocatable :: igpig(:,:)
real(8), allocatable :: vgqc(:,:),gqc(:),gclgq(:),jlgqr(:,:,:)
complex(8), allocatable :: ylmgq(:,:),sfacgq(:,:)
complex(8), allocatable :: wfmt1(:,:,:,:),wfir1(:,:,:)
complex(8), allocatable :: wfmt2(:,:,:,:),wfir2(:,:,:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:)
complex(8), allocatable :: zvv(:,:,:),zcc(:,:,:)
complex(8), allocatable :: zvc(:,:,:),zcv(:,:,:)
complex(8), allocatable :: epsi(:,:,:)
allocate(igpig(ngkmax,nspnfv))
allocate(vgqc(3,ngrf),gqc(ngrf),gclgq(ngrf))
allocate(jlgqr(njcmax,nspecies,ngrf))
allocate(ylmgq(lmmaxo,ngrf),sfacgq(ngrf,natmtot))
allocate(wfmt1(npcmtmax,natmtot,nspinor,nstsv),wfir1(ngtc,nspinor,nstsv))
allocate(wfmt2(npcmtmax,natmtot,nspinor,nstsv),wfir2(ngtc,nspinor,nstsv))
allocate(zvv(ngrf,nvbse,nvbse),zcc(ngrf,ncbse,ncbse))
allocate(epsi(ngrf,ngrf,nwrf))
if (bsefull) then
allocate(zvc(ngrf,nvbse,ncbse))
allocate(zcv(ngrf,ncbse,nvbse))
end if
! index to all states
do ist1=1,nstsv
idx(ist1)=ist1
end do
! generate the wavefunctions for all states of k-point ik2
call genwfsvp(.false.,.false.,nstsv,idx,ngdc,igfc,vkl(:,ik2),ngp,igpig,wfmt2, &
ngtc,wfir2)
! begin loop over ik1
do ik1=1,nkptnr
! generate the wavefunctions for all states of k-point ik1
call genwfsvp(.false.,.false.,nstsv,idx,ngdc,igfc,vkl(:,ik1),ngp,igpig, &
wfmt1,ngtc,wfir1)
! determine equivalent q-vector in first Brillouin zone
iv(:)=ivk(:,ik1)-ivk(:,ik2)
iv(:)=modulo(iv(:),ngridk(:))
iq=iqmap(iv(1),iv(2),iv(3))
! q-vector in lattice and Cartesian coordinates
vl(:)=vkl(:,ik1)-vkl(:,ik2)
vc(:)=vkc(:,ik1)-vkc(:,ik2)
! generate the G+q-vectors and related quantities
call gengqrf(vc,vgqc,gqc,jlgqr,ylmgq,sfacgq)
! generate the regularised Coulomb Green's function in G+q-space
call gengclgq(.true.,iq,ngrf,gqc,gclgq)
! symmetrise the Coulomb Green's function
gclgq(:)=sqrt(gclgq(:))
! compute the matrix elements
call holdthd(nvbse,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zrhomt,zrhoir,ist1,ist2,i2) &
!$OMP NUM_THREADS(nthd)
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
!$OMP DO
do i1=1,nvbse
ist1=istbse(i1,ik1)
do i2=1,nvbse
ist2=istbse(i2,ik2)
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,ist2),wfir2(:,:,ist2), &
wfmt1(:,:,:,ist1),wfir1(:,:,ist1),zrhomt,zrhoir)
call zftzf(ngrf,jlgqr,ylmgq,ngrf,sfacgq,zrhomt,zrhoir,zvv(:,i1,i2))
end do
end do
!$OMP END DO
deallocate(zrhomt,zrhoir)
!$OMP END PARALLEL
call freethd(nthd)
! compute the matrix elements
call holdthd(ncbse,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zrhomt,zrhoir,jst1,jst2,j2) &
!$OMP NUM_THREADS(nthd)
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
!$OMP DO
do j1=1,ncbse
jst1=jstbse(j1,ik1)
do j2=1,ncbse
jst2=jstbse(j2,ik2)
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,jst2),wfir2(:,:,jst2), &
wfmt1(:,:,:,jst1),wfir1(:,:,jst1),zrhomt,zrhoir)
call zftzf(ngrf,jlgqr,ylmgq,ngrf,sfacgq,zrhomt,zrhoir,zcc(:,j1,j2))
end do
end do
!$OMP END DO
deallocate(zrhomt,zrhoir)
!$OMP END PARALLEL
call freethd(nthd)
! matrix elements for full BSE kernel if required
if (bsefull) then
! compute the matrix elements
call holdthd(nvbse,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zrhomt,zrhoir,ist1,jst2,j2) &
!$OMP NUM_THREADS(nthd)
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
!$OMP DO
do i1=1,nvbse
ist1=istbse(i1,ik1)
do j2=1,ncbse
jst2=jstbse(j2,ik2)
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,jst2),wfir2(:,:,jst2), &
wfmt1(:,:,:,ist1),wfir1(:,:,ist1),zrhomt,zrhoir)
call zftzf(ngrf,jlgqr,ylmgq,ngrf,sfacgq,zrhomt,zrhoir,zvc(:,i1,j2))
end do
end do
!$OMP END DO
deallocate(zrhomt,zrhoir)
!$OMP END PARALLEL
call freethd(nthd)
! compute the matrix elements
call holdthd(ncbse,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zrhomt,zrhoir,jst1,ist2,i2) &
!$OMP NUM_THREADS(nthd)
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
!$OMP DO
do j1=1,ncbse
jst1=jstbse(j1,ik1)
do i2=1,nvbse
ist2=istbse(i2,ik2)
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,ist2),wfir2(:,:,ist2), &
wfmt1(:,:,:,jst1),wfir1(:,:,jst1),zrhomt,zrhoir)
call zftzf(ngrf,jlgqr,ylmgq,ngrf,sfacgq,zrhomt,zrhoir,zcv(:,j1,i2))
end do
end do
!$OMP END DO
deallocate(zrhomt,zrhoir)
!$OMP END PARALLEL
call freethd(nthd)
end if
! get RPA inverse epsilon from file
call getcfgq('EPSINV.OUT',vl,ngrf,nwrf,epsi)
t0=wkptnr*omega
do i1=1,nvbse
do j1=1,ncbse
a1=ijkbse(i1,j1,ik1)
do i2=1,nvbse
do j2=1,ncbse
a2=ijkbse(i2,j2,ik2)
z1=0.d0
do ig=1,ngrf
t1=t0*gclgq(ig)
do jg=1,ngrf
t2=t1*gclgq(jg)
z1=z1+t2*epsi(ig,jg,1)*conjg(zcc(ig,j1,j2))*zvv(jg,i1,i2)
end do
end do
hmlbse(a1,a2)=hmlbse(a1,a2)-z1
! compute off-diagonal blocks if required
if (bsefull) then
b1=a1+nbbse
b2=a2+nbbse
hmlbse(b1,b2)=hmlbse(b1,b2)+conjg(z1)
z1=0.d0
do ig=1,ngrf
t1=t0*gclgq(ig)
do jg=1,ngrf
t2=t1*gclgq(jg)
z1=z1+t2*epsi(ig,jg,1)*conjg(zcv(ig,j1,i2))*zvc(jg,i1,j2)
end do
end do
hmlbse(a1,b2)=hmlbse(a1,b2)-z1
hmlbse(b1,a2)=hmlbse(b1,a2)+conjg(z1)
end if
! end loop over i2 and j2
end do
end do
! end loop over i1 and j1
end do
end do
! end loop over ik1
end do
deallocate(igpig,vgqc,gqc,gclgq,jlgqr)
deallocate(ylmgq,sfacgq)
deallocate(wfmt1,wfmt2,wfir1,wfir2)
deallocate(zvv,zcc,epsi)
if (bsefull) deallocate(zvc,zcv)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/dielectric_bse.f90 0000644 0000000 0000000 00000000132 13543334734 016106 x ustar 00 30 mtime=1569569244.736641877
30 atime=1569569240.915644317
30 ctime=1569569244.736641877
elk-6.3.2/src/dielectric_bse.f90 0000644 0025044 0025044 00000006525 13543334734 020165 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine dielectric_bse
use modmain
use modtest
implicit none
! local variables
integer a1,a2,ik1,jk1
integer i1,j1,ist1,jst1
integer iw,i,j,l
integer ios,nmbse_
real(8) e,eji,t1,t2
complex(8) eta,zv(3),z1
character(256) fname
! allocatable arrays
real(8), allocatable :: w(:)
complex(8), allocatable :: pmat(:,:,:),sigma(:,:,:)
! initialise global variables
call init0
call init1
! read Fermi energy from a file
call readfermi
! get the eigenvalues from file
do ik1=1,nkpt
call getevalsv(filext,ik1,vkl(:,ik1),evalsv(:,ik1))
end do
! generate the BSE state index arrays
call genidxbse
! allocate global BSE arrays
if (allocated(evalbse)) deallocate(evalbse)
allocate(evalbse(nmbse))
if (allocated(hmlbse)) deallocate(hmlbse)
allocate(hmlbse(nmbse,nmbse))
! read in the BSE eigenvectors and eigenvalues
open(50,file='EVBSE.OUT',form='UNFORMATTED',status='OLD',iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(dielectric_bse): error opening EVBSE.OUT")')
write(*,*)
stop
end if
read(50) nmbse_
if (nmbse.ne.nmbse_) then
write(*,*)
write(*,'("Error(dielectric_bse): differing nmbse")')
write(*,'(" current : ",I6)') nmbse
write(*,'(" EVBSE.OUT : ",I6)') nmbse_
stop
end if
read(50) evalbse
read(50) hmlbse
close(50)
! allocate local arrays
allocate(w(nwplot))
allocate(pmat(nstsv,nstsv,3))
allocate(sigma(3,3,nwplot))
! set up the frequency grid (starting from zero)
t1=wplot(2)/dble(nwplot)
do iw=1,nwplot
w(iw)=t1*dble(iw-1)
end do
! i divided by the complex relaxation time
eta=cmplx(0.d0,swidth,8)
sigma(:,:,:)=0.d0
do a2=1,nmbse
e=evalbse(a2)
zv(:)=0.d0
! loop over non-reduced k-points
do ik1=1,nkptnr
! equivalent reduced k-point
jk1=ivkik(ivk(1,ik1),ivk(2,ik1),ivk(3,ik1))
! read the momentum matrix elements from file
call getpmat(vkl(:,ik1),pmat)
do i1=1,nvbse
ist1=istbse(i1,ik1)
do j1=1,ncbse
jst1=jstbse(j1,ik1)
a1=ijkbse(i1,j1,ik1)
eji=evalsv(jst1,jk1)-evalsv(ist1,jk1)
z1=(e/eji)*hmlbse(a1,a2)
zv(:)=zv(:)+z1*pmat(ist1,jst1,:)
end do
end do
end do
if (abs(e).gt.1.d-8) then
do i=1,3
do j=1,3
z1=zv(i)*conjg(zv(j))/e
sigma(i,j,:)=sigma(i,j,:)+z1/(w(:)-e+eta)+conjg(z1)/(w(:)+e+eta)
end do
end do
end if
end do
z1=zi*occmax*wkptnr/omega
sigma(:,:,:)=z1*sigma(:,:,:)
! loop over tensor components
do l=1,noptcomp
i=optcomp(1,l)
j=optcomp(2,l)
t1=0.d0
if (i.eq.j) t1=1.d0
write(fname,'("EPSILON_BSE_",2I1,".OUT")') i,j
open(50,file=trim(fname),form='FORMATTED')
do iw=1,nwplot
t2=t1-fourpi*aimag(sigma(i,j,iw)/(w(iw)+eta))
write(50,'(2G18.10)') w(iw),t2
end do
write(50,*)
do iw=1,nwplot
t2=fourpi*dble(sigma(i,j,iw)/(w(iw)+eta))
write(50,'(2G18.10)') w(iw),t2
end do
close(50)
end do
write(*,*)
write(*,'("Info(dielectric_bse):")')
write(*,'(" dielectric tensor written to EPSILON_BSE_ij.OUT")')
write(*,'(" for components")')
do l=1,noptcomp
write(*,'(" i = ",I1,", j = ",I1)') optcomp(1:2,l)
end do
! write sigma to test file
call writetest(187,'BSE optical conductivity',nv=nwplot,tol=1.d-3,zva=sigma)
deallocate(w,pmat,sigma)
! deallocate global BSE arrays
deallocate(evalbse,hmlbse)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genidxbse.f90 0000644 0000000 0000000 00000000132 13543334734 015116 x ustar 00 30 mtime=1569569244.740641874
30 atime=1569569240.920644314
30 ctime=1569569244.740641874
elk-6.3.2/src/genidxbse.f90 0000644 0025044 0025044 00000007661 13543334734 017177 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine genidxbse
use modmain
implicit none
integer ik,jk,a,ntop
integer ist,jst,i,j,k
! allocatable arrays
integer, allocatable :: idx(:)
! check if the BSE extra valence or conduction states are in range
do i=1,nvxbse
ist=istxbse(i)
if ((ist.lt.1).or.(ist.gt.nstsv)) then
write(*,*)
write(*,'("Error(genidxbse): extra valence state out of range : ",I8)') ist
write(*,*)
stop
end if
end do
do j=1,ncxbse
jst=jstxbse(j)
if ((jst.lt.1).or.(jst.gt.nstsv)) then
write(*,*)
write(*,'("Error(genidxbse): extra conduction state out of range : ",I8)') &
jst
write(*,*)
stop
end if
end do
! number of valence states for transitions
nvbse=nvbse0+nvxbse
! number of conduction states for transitions
ncbse=ncbse0+ncxbse
if ((nvbse.le.0).or.(ncbse.le.0)) then
write(*,*)
write(*,'("Error(genidxbse): invalid number of valence or conduction &
&transition states : ",2I8)') nvbse,ncbse
write(*,*)
stop
end if
! total number of transitions
nvcbse=nvbse*ncbse
! block size in BSE matrix
nbbse=nvcbse*nkptnr
! BSE matrix size
if (bsefull) then
nmbse=2*nbbse
else
nmbse=nbbse
end if
allocate(idx(nstsv))
! allocate global BSE index arrays
if (allocated(istbse)) deallocate(istbse)
allocate(istbse(nvbse,nkptnr))
if (allocated(jstbse)) deallocate(jstbse)
allocate(jstbse(ncbse,nkptnr))
if (allocated(ijkbse)) deallocate(ijkbse)
allocate(ijkbse(nvbse,ncbse,nkptnr))
a=0
! loop over non-reduced k-points
do ik=1,nkptnr
! equivalent reduced k-point
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
! index for sorting the eigenvalues into ascending order
call sortidx(nstsv,evalsv(:,jk),idx)
! find the topmost occupied band
ntop=nstsv
do ist=nstsv,1,-1
if (evalsv(idx(ist),jk).lt.efermi) then
ntop=ist
exit
end if
end do
if ((ntop-nvbse0+1).lt.1) then
write(*,*)
write(*,'("Error(genidxbse): not enough valence states, reduce nvbse")')
write(*,*)
stop
end if
if ((ntop+ncbse0).gt.nstsv) then
write(*,*)
write(*,'("Error(genidxbse): not enough conduction states")')
write(*,'(" reduce ncbse or increase nempty")')
write(*,*)
stop
end if
! index from BSE valence states to second-variational state numbers
do i=1,nvbse0
istbse(i,ik)=idx(ntop-nvbse0+i)
end do
! index from BSE conduction states to second-variational state numbers
do j=1,ncbse0
jstbse(j,ik)=idx(ntop+j)
end do
! add extra states to the list
do i=1,nvxbse
ist=istxbse(i)
if (evalsv(ist,jk).gt.efermi) then
write(*,*)
write(*,'("Error(genidxbse): extra valence state above Fermi energy : ",&
&I6)') ist
write(*,'(" for k-point ",I8)') jk
write(*,*)
stop
end if
do k=1,nvbse0+i-1
if (ist.eq.istbse(k,ik)) then
write(*,*)
write(*,'("Error(genidxbse): redundant extra valence state : ",I6)') ist
write(*,'(" for k-point ",I8)') jk
write(*,*)
stop
end if
end do
istbse(nvbse0+i,ik)=ist
end do
do j=1,ncxbse
jst=jstxbse(j)
if (evalsv(jst,jk).lt.efermi) then
write(*,*)
write(*,'("Error(genidxbse): extra conduction state below Fermi &
&energy : ",I6)') jst
write(*,'(" for k-point ",I8)') jk
write(*,*)
stop
end if
do k=1,ncbse0+j-1
if (jst.eq.jstbse(k,ik)) then
write(*,*)
write(*,'("Error(genidxbse): redundant extra conduction state : ",&
&I6)') jst
write(*,'(" for k-point ",I8)') jk
write(*,*)
stop
end if
end do
jstbse(ncbse0+j,ik)=jst
end do
! index from BSE valence-conduction pair and k-point to location in BSE matrix
do i=1,nvbse
do j=1,ncbse
a=a+1
ijkbse(i,j,ik)=a
end do
end do
! end loop over non-reduced k-points
end do
deallocate(idx)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writeevbse.f90 0000644 0000000 0000000 00000000131 13543334734 015324 x ustar 00 30 mtime=1569569244.745641871
29 atime=1569569240.92664431
30 ctime=1569569244.745641871
elk-6.3.2/src/writeevbse.f90 0000644 0025044 0025044 00000005475 13543334734 017407 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine writeevbse
use modmain
use modomp
implicit none
! local variables
integer ik,a,nthd
integer ios,nmbse_
integer lwork,info
! allocatable arrays
real(8), allocatable :: rwork(:)
complex(8), allocatable :: w(:),vl(:,:),vr(:,:)
complex(8), allocatable :: work(:)
! initialise global variables
call init0
call init1
! read Fermi energy from a file
call readfermi
! get the eigenvalues from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
end do
! generate the BSE state index arrays
call genidxbse
! allocate global BSE arrays
if (allocated(evalbse)) deallocate(evalbse)
allocate(evalbse(nmbse))
if (allocated(hmlbse)) deallocate(hmlbse)
allocate(hmlbse(nmbse,nmbse))
! read in BSE Hamiltonian matrix
open(50,file='HMLBSE.OUT',form='UNFORMATTED',status='OLD',iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(writeevbse): error opening HMLBSE.OUT")')
write(*,*)
stop
end if
read(50) nmbse_
if (nmbse.ne.nmbse_) then
write(*,*)
write(*,'("Error(writeevbse): differing nmbse")')
write(*,'(" current : ",I6)') nmbse
write(*,'(" HMLBSE.OUT : ",I6)') nmbse_
write(*,*)
stop
end if
read(50) hmlbse
close(50)
write(*,*)
write(*,'("Info(writeevbse): diagonalising the BSE Hamiltonian matrix")')
if (bsefull) then
! full non-Hermitian matrix
allocate(w(nmbse))
allocate(vl(1,1),vr(nmbse,nmbse))
lwork=2*nmbse
allocate(rwork(lwork),work(lwork))
! enable MKL parallelism
call holdthd(maxthdmkl,nthd)
call mkl_set_num_threads(nthd)
call zgeev('N','V',nmbse,hmlbse,nmbse,w,vl,1,vr,nmbse,work,lwork,rwork,info)
call freethd(nthd)
call mkl_set_num_threads(1)
if (info.ne.0) then
write(*,*)
write(*,'("Error(writeevbse): diagonalisation failed")')
write(*,'(" ZGEEV returned INFO = ",I8)') info
write(*,*)
stop
end if
evalbse(:)=dble(w(:))
hmlbse(:,:)=vr(:,:)
deallocate(vl,vr,rwork,work)
else
! Hermitian block only
call eveqnz(nmbse,nmbse,hmlbse,evalbse)
end if
! write the BSE eigenvectors and eigenvalues to file
open(50,file='EVBSE.OUT',form='UNFORMATTED')
write(50) nmbse
write(50) evalbse
write(50) hmlbse
close(50)
! write the BSE eigenvalues to file
open(50,file='EIGVAL_BSE.OUT',form='FORMATTED')
write(50,'(I6," : nmbse")') nmbse
if (bsefull) then
do a=1,nmbse
write(50,'(I6,2G18.10)') a,dble(w(a)),aimag(w(a))
end do
deallocate(w)
else
do a=1,nmbse
write(50,'(I6,G18.10)') a,evalbse(a)
end do
end if
close(50)
write(*,*)
write(*,'("Info(writeevbse):")')
write(*,'(" BSE eigenvectors and eigenvalues written to EVBSE.OUT")')
write(*,'(" BSE eigenvalues written to EIGVAL_BSE.OUT")')
! deallocate global BSE arrays
deallocate(evalbse,hmlbse)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genwfpw.f90 0000644 0000000 0000000 00000000132 13543334734 014623 x ustar 00 30 mtime=1569569244.749641868
30 atime=1569569240.931644307
30 ctime=1569569244.749641868
elk-6.3.2/src/genwfpw.f90 0000644 0025044 0025044 00000013775 13543334734 016707 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.
subroutine genwfpw(vpl,ngp,igpig,vgpl,vgpc,gpc,sfacgp,nhp,vhpc,hpc,sfachp,wfpw)
use modmain
use modpw
implicit none
! arguments
real(8), intent(in) :: vpl(3)
integer, intent(in) :: ngp(nspnfv),igpig(ngkmax,nspnfv)
real(8), intent(in) :: vgpl(3,ngkmax,nspnfv),vgpc(3,ngkmax,nspnfv)
real(8), intent(in) :: gpc(ngkmax,nspnfv)
complex(8), intent(in) :: sfacgp(ngkmax,natmtot,nspnfv)
integer, intent(in) :: nhp(nspnfv)
real(8), intent(in) :: vhpc(3,nhkmax,nspnfv),hpc(nhkmax,nspnfv)
complex(8), intent(in) :: sfachp(nhkmax,natmtot,nspnfv)
complex(8), intent(out) :: wfpw(nhkmax,nspinor,nstsv)
! local variables
integer ispn0,ispn1,ispn,jspn
integer ist,is,ia,ias
integer nrc,nrci,irco,irc
integer lmax,l,m,lm
integer npci,i,igp,ihp
real(8) t0,t1,t2
complex(8) z1,z2,z3,z4
! automatic arrays
integer idx(nstsv)
real(8) fr1(nrcmtmax),fr2(nrcmtmax)
complex(8) ylm(lmmaxo)
! allocatable arrays
real(8), allocatable :: jl(:,:)
complex(8), allocatable :: apwalm(:,:,:,:,:)
complex(8), allocatable :: evecfv(:,:,:),evecsv(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfir(:,:,:)
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
allocate(evecfv(nmatmax,nstfv,nspnfv),evecsv(nstsv,nstsv))
allocate(wfmt(npcmtmax,natmtot,nspinor,nstsv))
allocate(wfir(ngkmax,nspinor,nstsv))
! get the eigenvectors from file
call getevecfv(filext,0,vpl,vgpl,evecfv)
call getevecsv(filext,0,vpl,evecsv)
! find the matching coefficients
do ispn=1,nspnfv
call match(ngp(ispn),vgpc(:,:,ispn),gpc(:,ispn),sfacgp(:,:,ispn), &
apwalm(:,:,:,:,ispn))
end do
! index to all states
do ist=1,nstsv
idx(ist)=ist
end do
! calculate the second-variational wavefunctions for all states
call genwfsv(.true.,.true.,nstsv,idx,ngridg,igfft,ngp,igpig,apwalm,evecfv, &
evecsv,wfmt,ngkmax,wfir)
deallocate(apwalm,evecfv,evecsv)
! zero the plane wave coefficients
wfpw(:,:,:)=0.d0
!---------------------------!
! interstitial part !
!---------------------------!
do jspn=1,nspnfv
if (spinsprl) then
ispn0=jspn; ispn1=jspn
else
ispn0=1; ispn1=nspinor
end if
i=1
do ihp=1,nhp(jspn)
do igp=i,ngp(jspn)
t1=abs(vhpc(1,ihp,jspn)-vgpc(1,igp,jspn)) &
+abs(vhpc(2,ihp,jspn)-vgpc(2,igp,jspn)) &
+abs(vhpc(3,ihp,jspn)-vgpc(3,igp,jspn))
if (t1.lt.epslat) then
do ist=1,nstsv
do ispn=ispn0,ispn1
wfpw(ihp,ispn,ist)=wfir(igp,ispn,ist)
end do
end do
if (igp.eq.i) i=i+1
exit
end if
end do
end do
end do
!-------------------------!
! muffin-tin part !
!-------------------------!
allocate(jl(0:lmaxo,nrcmtmax))
t0=fourpi/sqrt(omega)
! remove continuation of interstitial function into muffin-tin
do jspn=1,nspnfv
if (spinsprl) then
ispn0=jspn; ispn1=jspn
else
ispn0=1; ispn1=nspinor
end if
! loop over G+p-vectors
do igp=1,ngp(jspn)
! generate the conjugate spherical harmonics Y_lm*(G+p)
call genylmv(lmaxo,vgpc(:,igp,jspn),ylm)
ylm(:)=conjg(ylm(:))
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
irco=nrci+1
npci=npcmti(is)
! generate spherical Bessel functions
lmax=lmaxi
do irc=1,nrc
t1=gpc(igp,jspn)*rcmt(irc,is)
call sbessel(lmax,t1,jl(:,irc))
if (irc.eq.nrci) lmax=lmaxo
end do
! loop over atoms
do ia=1,natoms(is)
ias=idxas(ia,is)
z1=t0*sfacgp(igp,ias,jspn)
do ist=1,nstsv
do ispn=ispn0,ispn1
z2=z1*wfir(igp,ispn,ist)
lm=0
do l=0,lmaxi
z3=z2*zil(l)
do m=-l,l
lm=lm+1
z4=z3*ylm(lm)
i=lm
do irc=1,nrci
wfmt(i,ias,ispn,ist)=wfmt(i,ias,ispn,ist)-z4*jl(l,irc)
i=i+lmmaxi
end do
end do
end do
lm=0
do l=0,lmaxo
z3=z2*zil(l)
do m=-l,l
lm=lm+1
z4=z3*ylm(lm)
i=npci+lm
do irc=irco,nrc
wfmt(i,ias,ispn,ist)=wfmt(i,ias,ispn,ist)-z4*jl(l,irc)
i=i+lmmaxo
end do
end do
end do
end do
end do
end do
end do
end do
end do
! Fourier transform the muffin-tin wavefunctions
do jspn=1,nspnfv
if (spinsprl) then
ispn0=jspn; ispn1=jspn
else
ispn0=1; ispn1=nspinor
end if
! loop over H+p-vectors
do ihp=1,nhp(jspn)
! generate the spherical harmonics Y_lm(H+p)
call genylmv(lmaxo,vhpc(:,ihp,jspn),ylm)
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
! generate spherical Bessel functions
lmax=lmaxi
do irc=1,nrc
t1=hpc(ihp,jspn)*rcmt(irc,is)
call sbessel(lmax,t1,jl(:,irc))
if (irc.eq.nrci) lmax=lmaxo
end do
do ia=1,natoms(is)
ias=idxas(ia,is)
! conjugate structure factor
z3=t0*conjg(sfachp(ihp,ias,jspn))
! loop over states
do ist=1,nstsv
do ispn=ispn0,ispn1
lmax=lmaxi
i=0
do irc=1,nrc
i=i+1
z1=jl(0,irc)*wfmt(i,ias,ispn,ist)*ylm(1)
lm=1
do l=1,lmax
lm=lm+1
i=i+1
z2=wfmt(i,ias,ispn,ist)*ylm(lm)
do m=1-l,l
lm=lm+1
i=i+1
z2=z2+wfmt(i,ias,ispn,ist)*ylm(lm)
end do
z1=z1+jl(l,irc)*zilc(l)*z2
end do
fr1(irc)=dble(z1); fr2(irc)=aimag(z1)
if (irc.eq.nrci) lmax=lmaxo
end do
t1=dot_product(wrcmt(1:nrc,is),fr1(1:nrc))
t2=dot_product(wrcmt(1:nrc,is),fr2(1:nrc))
! add to the H+p wavefunction
wfpw(ihp,ispn,ist)=wfpw(ihp,ispn,ist)+z3*cmplx(t1,t2,8)
end do
end do
end do
end do
end do
end do
deallocate(jl,wfmt,wfir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writewfpw.f90 0000644 0000000 0000000 00000000132 13543334734 015204 x ustar 00 30 mtime=1569569244.753641866
30 atime=1569569240.937644303
30 ctime=1569569244.753641866
elk-6.3.2/src/writewfpw.f90 0000644 0025044 0025044 00000004160 13543334734 017254 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.
subroutine writewfpw
use modmain
use modpw
use modmpi
use modomp
implicit none
! local variables
integer ik,recl,nthd
! allocatable arrays
complex(8), allocatable :: wfpw(:,:,:)
! initialise global variables
call init0
call init1
call init4
! read density and potentials from file
call readstate
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! delete existing WFPW.OUT
if (mp_mpi) then
open(170,file='WFPW.OUT')
close(170,status='DELETE')
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
! determine the record length and open WFPW.OUT
allocate(wfpw(nhkmax,nspinor,nstsv))
inquire(iolength=recl) vkl(:,1),nhkmax,nspinor,nstsv,wfpw
deallocate(wfpw)
open(170,file='WFPW.OUT',form='UNFORMATTED',access='DIRECT',recl=recl)
! begin parallel loop over k-points
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfpw) &
!$OMP NUM_THREADS(nthd)
allocate(wfpw(nhkmax,nspinor,nstsv))
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
!$OMP CRITICAL(writewfpw_)
write(*,'("Info(writewfpw): ",I6," of ",I6," k-points")') ik,nkpt
!$OMP END CRITICAL(writewfpw_)
! generate the plane wave wavefunctions
call genwfpw(vkl(:,ik),ngk(:,ik),igkig(:,:,ik),vgkl(:,:,:,ik), &
vgkc(:,:,:,ik),gkc(:,:,ik),sfacgk(:,:,:,ik),nhk(:,ik),vhkc(:,:,:,ik), &
hkc(:,:,ik),sfachk(:,:,:,ik),wfpw)
!$OMP CRITICAL(u170)
write(170,rec=ik) vkl(:,ik),nhkmax,nspinor,nstsv,wfpw
!$OMP END CRITICAL(u170)
end do
!$OMP END DO
deallocate(wfpw)
!$OMP END PARALLEL
call freethd(nthd)
close(170)
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
if (mp_mpi) then
write(*,*)
write(*,'("Info(writewfpw): plane wave wavefunctions written to WFPW.OUT")')
write(*,'(" for all H+k-vectors up to |H+k| < hkmax")')
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/getwfpw.f90 0000644 0000000 0000000 00000000130 13543334734 014627 x ustar 00 30 mtime=1569569244.758641862
28 atime=1569569240.9416443
30 ctime=1569569244.758641862
elk-6.3.2/src/getwfpw.f90 0000644 0025044 0025044 00000012012 13543334734 016674 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.
subroutine getwfpw(vpl,vhpl,wfpw)
use modmain
use modpw
implicit none
! arguments
real(8), intent(in) :: vpl(3)
real(8), intent(in) :: vhpl(3,nhkmax,nspnfv)
complex(8), intent(out) :: wfpw(nhkmax,nspinor,nstsv)
! local variables
integer isym,lspl,ilspl,lspn
integer ik,ist,ihk,ihp,jhp,ig
integer ispn0,ispn1,jspn,i
integer recl,nhkmax_,nspinor_,nstsv_
real(8) vkl_(3),si(3,3)
real(8) v(3),det,th,t1
complex(8) su2(2,2),z1,z2
! automatic arrays
logical done(nhkmax)
! allocatable arrays
complex(8), allocatable :: wfpw_(:,:,:)
! find the equivalent k-point number and symmetry which rotates vkl to vpl
call findkpt(vpl,isym,ik)
! index to spatial rotation in lattice point group
lspl=lsplsymc(isym)
! find the record length
inquire(iolength=recl) vkl_,nhkmax_,nspinor_,nstsv_,wfpw
!$OMP CRITICAL(u170)
open(170,file='WFPW.OUT',form='UNFORMATTED',access='DIRECT',recl=recl)
read(170,rec=ik) vkl_,nhkmax_,nspinor_,nstsv_,wfpw
close(170)
!$OMP END CRITICAL(u170)
t1=abs(vkl(1,ik)-vkl_(1))+abs(vkl(2,ik)-vkl_(2))+abs(vkl(3,ik)-vkl_(3))
if (t1.gt.epslat) then
write(*,*)
write(*,'("Error(getwfpw): differing vectors for k-point ",I8)') ik
write(*,'(" current : ",3G18.10)') vkl(:,ik)
write(*,'(" WFPW.OUT : ",3G18.10)') vkl_
write(*,*)
stop
end if
if (nhkmax.ne.nhkmax_) then
write(*,*)
write(*,'("Error(getwfpw): differing nhkmax for k-point ",I8)') ik
write(*,'(" current : ",I8)') nhkmax
write(*,'(" WFPW.OUT : ",I8)') nhkmax_
write(*,*)
stop
end if
if (nspinor.ne.nspinor_) then
write(*,*)
write(*,'("Error(getwfpw): differing nspinor for k-point ",I8)') ik
write(*,'(" current : ",I8)') nspinor
write(*,'(" WFPW.OUT : ",I8)') nspinor_
write(*,*)
stop
end if
if (nstsv.ne.nstsv_) then
write(*,*)
write(*,'("Error(getwfpw): differing nstsv for k-point ",I8)') ik
write(*,'(" current : ",I8)') nstsv
write(*,'(" WFPW.OUT : ",I8)') nstsv_
write(*,*)
stop
end if
! if p = k then return
t1=abs(vpl(1)-vkl(1,ik))+abs(vpl(2)-vkl(2,ik))+abs(vpl(3)-vkl(3,ik))
if (t1.lt.epslat) return
!--------------------------------------------------------!
! translate and rotate wavefunction coefficients !
!--------------------------------------------------------!
! allocate temporary copy of wavefunction
allocate(wfpw_(nhkmax,nspinor,nstsv))
! the inverse of the spatial symmetry
ilspl=isymlat(lspl)
si(:,:)=dble(symlat(:,:,ilspl))
! loop over first-variational spins
do jspn=1,nspnfv
if (spinsprl) then
ispn0=jspn; ispn1=jspn
else
ispn0=1; ispn1=nspinor
end if
! apply translation operation if required
if (tv0symc(isym)) then
! translation vector is zero
do ihk=1,nhk(jspn,ik)
wfpw_(ihk,ispn0:ispn1,:)=wfpw(ihk,ispn0:ispn1,:)
end do
else
! non-zero translation vector gives a phase factor
v(:)=vtcsymc(:,isym)
do ihk=1,nhk(jspn,ik)
ig=ihkig(ihk,jspn,ik)
t1=-(vgc(1,ig)*v(1)+vgc(2,ig)*v(2)+vgc(3,ig)*v(3))
z1=cmplx(cos(t1),sin(t1),8)
wfpw_(ihk,ispn0:ispn1,:)=z1*wfpw(ihk,ispn0:ispn1,:)
end do
end if
! apply spatial rotation operation (passive transformation)
done(1:nhk(jspn,ik))=.false.
i=1
do ihk=1,nhk(jspn,ik)
call r3mtv(si,vhkl(:,ihk,jspn,ik),v)
do ihp=i,nhk(jspn,ik)
if (done(ihp)) cycle
t1=abs(v(1)-vhpl(1,ihp,jspn)) &
+abs(v(2)-vhpl(2,ihp,jspn)) &
+abs(v(3)-vhpl(3,ihp,jspn))
if (t1.lt.epslat) then
wfpw(ihp,ispn0:ispn1,:)=wfpw_(ihk,ispn0:ispn1,:)
done(ihp)=.true.
exit
end if
end do
do ihp=i,nhk(jspn,ik)
if (.not.done(ihp)) then
i=ihp
exit
end if
end do
end do
end do
! apply spin rotation if required
if (spinpol) then
! index to global spin rotation in lattice point group
lspn=lspnsymc(isym)
! if symmetry element is the identity return
if (lspn.eq.1) return
! find the SU(2) representation of the spin rotation matrix
call rotaxang(epslat,symlatc(:,:,lspn),det,v,th)
call axangsu2(v,th,su2)
! apply SU(2) matrix to spinor wavefunctions (active transformation)
if (spinsprl) then
! spin-spiral case
wfpw(:,2,:)=0.d0
i=1
do ihp=1,nhk(1,ik)
v(:)=vhpl(:,ihp,1)-vqlss(:)
do jhp=i,nhk(2,ik)
t1=abs(v(1)-vhpl(1,jhp,2)) &
+abs(v(2)-vhpl(2,jhp,2)) &
+abs(v(3)-vhpl(3,jhp,2))
if (t1.lt.epslat) then
do ist=1,nstsv
z1=wfpw(ihp,1,ist)
z2=wfpw(jhp,2,ist)
wfpw(ihp,1,ist)=su2(1,1)*z1+su2(1,2)*z2
wfpw(jhp,2,ist)=su2(2,1)*z1+su2(2,2)*z2
end do
if (jhp.eq.i) i=i+1
goto 10
end if
end do
wfpw(ihp,1,:)=0.d0
10 continue
end do
else
! normal spin case
do ist=1,nstsv
do ihp=1,nhk(1,ik)
z1=wfpw(ihp,1,ist)
z2=wfpw(ihp,2,ist)
wfpw(ihp,1,ist)=su2(1,1)*z1+su2(1,2)*z2
wfpw(ihp,2,ist)=su2(2,1)*z1+su2(2,2)*z2
end do
end do
end if
end if
deallocate(wfpw_)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genexpmat.f90 0000644 0000000 0000000 00000000132 13543334734 015136 x ustar 00 30 mtime=1569569244.763641859
30 atime=1569569240.947644297
30 ctime=1569569244.763641859
elk-6.3.2/src/genexpmat.f90 0000644 0025044 0025044 00000012525 13543334734 017212 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.
subroutine genexpmat(vpl,expmt,emat)
use modmain
implicit none
! arguments
real(8), intent(in) :: vpl(3)
complex(8), intent(in) :: expmt(npcmtmax,natmtot)
complex(8), intent(out) :: emat(nstsv,nstsv)
! local variables
integer ist,jst,ispn,i,j,k,l
integer is,ia,ias,nrc,nrci
integer npc,ngp,ngpq,igp,ifg
real(8) vpc(3),vpql(3),vpqc(3),t1
complex(8) z1
! allocatable arrays
integer, allocatable :: igpig(:),igpqig(:)
real(8), allocatable :: vgpl(:,:),vgpc(:,:),gpc(:)
real(8), allocatable :: vgpql(:,:),vgpqc(:,:),gpqc(:)
complex(8), allocatable :: sfacgp(:,:),sfacgpq(:,:)
complex(8), allocatable :: apwalm1(:,:,:,:),apwalm2(:,:,:,:)
complex(8), allocatable :: evecfv1(:,:),evecfv2(:,:)
complex(8), allocatable :: evecsv1(:,:),evecsv2(:,:)
complex(8), allocatable :: wfmt1(:),wfmt2(:,:)
complex(8), allocatable :: zfir(:),x(:),em(:,:)
! external functions
complex(8) zfmtinp,zdotc
external zfmtinp,zdotc
! check if q-vector is zero
t1=abs(vecql(1))+abs(vecql(2))+abs(vecql(3))
if (t1.lt.epslat) then
emat(:,:)=0.d0
do i=1,nstsv
emat(i,i)=1.d0
end do
return
end if
! allocate local arrays
allocate(igpig(ngkmax),igpqig(ngkmax))
allocate(vgpl(3,ngkmax),vgpc(3,ngkmax),gpc(ngkmax))
allocate(vgpql(3,ngkmax),vgpqc(3,ngkmax),gpqc(ngkmax))
allocate(sfacgp(ngkmax,natmtot),sfacgpq(ngkmax,natmtot))
allocate(apwalm1(ngkmax,apwordmax,lmmaxapw,natmtot))
allocate(apwalm2(ngkmax,apwordmax,lmmaxapw,natmtot))
allocate(evecfv1(nmatmax,nstfv),evecfv2(nmatmax,nstfv))
if (tevecsv) then
allocate(evecsv1(nstsv,nstsv),evecsv2(nstsv,nstsv))
end if
allocate(wfmt1(npcmtmax),wfmt2(npcmtmax,nstfv))
allocate(zfir(ngtot),x(ngkmax),em(nstfv,nstfv))
! p-vector in Cartesian coordinates
call r3mv(bvec,vpl,vpc)
! generate the G+p-vectors
call gengkvec(ngvec,ivg,vgc,vpl,vpc,gkmax,ngkmax,ngp,igpig,vgpl,vgpc,gpc)
! generate the structure factors
call gensfacgp(ngp,vgpc,ngkmax,sfacgp)
! find the matching coefficients for k-point p
call match(ngp,vgpc,gpc,sfacgp,apwalm1)
! get the eigenvectors for k-point p
call getevecfv(filext,0,vpl,vgpl,evecfv1)
! p+q-vector in lattice coordinates
vpql(:)=vpl(:)+vecql(:)
! p+q-vector in Cartesian coordinates
call r3mv(bvec,vpql,vpqc)
! generate the G+p+q-vectors
call gengkvec(ngvec,ivg,vgc,vpql,vpqc,gkmax,ngkmax,ngpq,igpqig,vgpql,vgpqc,gpqc)
! generate the structure factors
call gensfacgp(ngpq,vgpqc,ngkmax,sfacgpq)
! find the matching coefficients for k-point p+q
call match(ngpq,vgpqc,gpqc,sfacgpq,apwalm2)
! get the eigenvectors for k-point p+q
call getevecfv(filext,0,vpql,vgpql,evecfv2)
! set the first-variational matrix element array to zero
em(:,:)=0.d0
!------------------------------------!
! muffin-tin matrix elements !
!------------------------------------!
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
do ist=1,nstfv
! calculate the wavefunction for k-point p+q
call wavefmt(lradstp,ias,ngpq,apwalm2(:,:,:,ias),evecfv2(:,ist),wfmt1)
! convert from spherical harmonics to spherical coordinates
call zbsht(nrc,nrci,wfmt1,wfmt2(:,ist))
! multiply by exp(-iq.r) (conjugate because zfmtinp conjugates first function)
wfmt1(1:npc)=conjg(expmt(1:npc,ias))*wfmt2(1:npc,ist)
! convert from spherical coordinates to spherical harmonics
call zfsht(nrc,nrci,wfmt1,wfmt2(:,ist))
end do
do jst=1,nstfv
! calculate the wavefunction for k-point p
call wavefmt(lradstp,ias,ngp,apwalm1(:,:,:,ias),evecfv1(:,jst),wfmt1)
do ist=1,nstfv
em(ist,jst)=em(ist,jst)+zfmtinp(nrc,nrci,wrcmt(:,is),wfmt2(:,ist),wfmt1)
end do
end do
! end loops over atoms and species
end do
end do
!--------------------------------------!
! interstitial matrix elements !
!--------------------------------------!
! compute interstitial wavefunctions for k-point p
do jst=1,nstfv
zfir(:)=0.d0
do igp=1,ngp
ifg=igfft(igpig(igp))
zfir(ifg)=evecfv1(igp,jst)
end do
! Fourier transform wavefunction to real-space
call zfftifc(3,ngridg,1,zfir)
! multiply with the characteristic function
zfir(:)=zfir(:)*cfunir(:)
! Fourier transform back to G-space
call zfftifc(3,ngridg,-1,zfir)
! store as wavefunction with G+p+q index
do igp=1,ngpq
ifg=igfft(igpqig(igp))
x(igp)=zfir(ifg)
end do
! add to the first-variational matrix elements
do ist=1,nstfv
em(ist,jst)=em(ist,jst)+zdotc(ngpq,evecfv2(:,ist),1,x,1)
end do
end do
!-------------------------------------------!
! second-variational matrix elements !
!-------------------------------------------!
if (tevecsv) then
! get the second-variational eigenvectors
call getevecsv(filext,0,vpl,evecsv1)
call getevecsv(filext,0,vpql,evecsv2)
do i=1,nstsv
do j=1,nstsv
z1=0.d0
k=0
do ispn=1,nspinor
do ist=1,nstfv
k=k+1
l=(ispn-1)*nstfv
do jst=1,nstfv
l=l+1
z1=z1+em(ist,jst)*conjg(evecsv2(k,i))*evecsv1(l,j)
end do
end do
end do
emat(i,j)=z1
end do
end do
else
emat(:,:)=em(:,:)
end if
deallocate(igpig,igpqig,vgpl,vgpc,gpc)
deallocate(vgpql,vgpqc,gpqc,sfacgp,sfacgpq)
deallocate(apwalm1,apwalm2,evecfv1,evecfv2)
if (tevecsv) deallocate(evecsv1,evecsv2)
deallocate(wfmt1,wfmt2,zfir,x,em)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/elnes.f90 0000644 0000000 0000000 00000000132 13543334734 014254 x ustar 00 30 mtime=1569569244.767641857
30 atime=1569569240.952644293
30 ctime=1569569244.767641857
elk-6.3.2/src/elnes.f90 0000644 0025044 0025044 00000007210 13543334734 016323 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.
subroutine elnes
use modmain
use modomp
use modtest
implicit none
! local variables
integer ik,jk,ikq,isym,nsk(3)
integer ist,jst,iw,n,nthd
real(8) vgqc(3),gqc
real(8) vkql(3),v(3)
real(8) q,wd,dw,w,t1
! allocatable arrays
real(8), allocatable :: jlgqr(:,:),ddcs(:)
real(8), allocatable :: e(:,:,:),f(:,:,:)
complex(8), allocatable :: ylmgq(:),sfacgq(:)
complex(8), allocatable :: expmt(:,:),emat(:,:)
! initialise universal variables
call init0
call init1
call init2
! check q-vector is commensurate with k-point grid
v(:)=dble(ngridk(:))*vecql(:)
v(:)=abs(v(:)-nint(v(:)))
if ((v(1).gt.epslat).or.(v(2).gt.epslat).or.(v(3).gt.epslat)) then
write(*,*)
write(*,'("Error(elnes): q-vector incommensurate with k-point grid")')
write(*,'(" ngridk : ",3I6)') ngridk
write(*,'(" vecql : ",3G18.10)') vecql
write(*,*)
stop
end if
! read in the density and potentials from file
call readstate
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! get the second-variational eigenvalues and occupancies from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! generate the phase factor function exp(iq.r) in the muffin-tins
allocate(jlgqr(njcmax,nspecies))
allocate(ylmgq(lmmaxo),sfacgq(natmtot))
allocate(expmt(npcmtmax,natmtot))
ngrf=1
call gengqrf(vecqc,vgqc,gqc,jlgqr,ylmgq,sfacgq)
call genexpmt(1,jlgqr,ylmgq,1,sfacgq,expmt)
deallocate(jlgqr,ylmgq,sfacgq)
allocate(e(nstsv,nstsv,nkptnr),f(nstsv,nstsv,nkptnr))
e(:,:,:)=0.d0
f(:,:,:)=0.d0
! begin parallel loop over non-reduced k-points
call holdthd(nkptnr,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(emat,jk,vkql,isym) &
!$OMP PRIVATE(ikq,ist,jst,t1) &
!$OMP NUM_THREADS(nthd)
allocate(emat(nstsv,nstsv))
!$OMP DO
do ik=1,nkptnr
!$OMP CRITICAL(elnes_)
write(*,'("Info(elnes): ",I6," of ",I6," k-points")') ik,nkptnr
!$OMP END CRITICAL(elnes_)
! equivalent reduced k-point
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
! k+q-vector in lattice coordinates
vkql(:)=vkl(:,ik)+vecql(:)
! index to k+q-vector
call findkpt(vkql,isym,ikq)
! compute < i,k+q | exp(iq.r) | j,k > matrix elements
call genexpmat(vkl(:,ik),expmt,emat)
! add to the double differential scattering cross-section
do jst=1,nstsv
if (evalsv(jst,jk).lt.emaxelnes) then
do ist=1,nstsv
e(ist,jst,ik)=evalsv(ist,ikq)-evalsv(jst,jk)
t1=dble(emat(ist,jst))**2+aimag(emat(ist,jst))**2
f(ist,jst,ik)=t1*occsv(jst,jk)*(occmax-occsv(ist,ikq))
end do
end if
end do
end do
!$OMP END DO
deallocate(emat)
!$OMP END PARALLEL
call freethd(nthd)
! number of subdivisions used for interpolation
nsk(:)=max(ngrkf/ngridk(:),1)
n=nstsv*nstsv
! integrate over the Brillouin zone
allocate(ddcs(nwplot))
call brzint(nswplot,ngridk,nsk,ivkiknr,nwplot,wplot,n,n,e,f,ddcs)
q=sqrt(vecqc(1)**2+vecqc(2)**2+vecqc(3)**2)
t1=2.d0/(omega*occmax)
if (q.gt.epslat) t1=t1/q**4
ddcs(:)=t1*ddcs(:)
open(50,file='ELNES.OUT',form='FORMATTED')
wd=wplot(2)-wplot(1)
dw=wd/dble(nwplot)
do iw=1,nwplot
w=dw*dble(iw-1)+wplot(1)
write(50,'(2G18.10)') w,ddcs(iw)
end do
close(50)
write(*,*)
write(*,'("Info(elnes):")')
write(*,'(" ELNES double differential cross-section written to ELNES.OUT")')
! write ELNES distribution to test file
call writetest(140,'ELNES cross-section',nv=nwplot,tol=1.d-2,rva=ddcs)
deallocate(e,f,ddcs,expmt)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/potefield.f90 0000644 0000000 0000000 00000000131 13543334734 015120 x ustar 00 30 mtime=1569569244.771641854
29 atime=1569569240.95764429
30 ctime=1569569244.771641854
elk-6.3.2/src/potefield.f90 0000644 0025044 0025044 00000003212 13543334734 017166 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.
subroutine potefield
use modmain
implicit none
! local variables
integer is,ia,ias
integer nr,nri,ir
integer i,i1,i2,i3
real(8) e,tp(2),r,t1
real(8) v0,e00,elm(-1:1)
real(8) v1(3),v2(3)
! constant added to potential so that it is zero at the unit cell center
v1(:)=0.5d0*(avec(:,1)+avec(:,2)+avec(:,3))
v0=dot_product(efieldc(:),v1(:))
! determine the electric field vector in spherical coordinates
call sphcrd(efieldc,e,tp)
! coefficients for real spherical harmonics R_1-1, R_10 and R_11
t1=e*sqrt(fourpi/3.d0)
elm(-1)=t1*sin(tp(1))*sin(tp(2))
elm(0)=-t1*cos(tp(1))
elm(1)=t1*sin(tp(1))*cos(tp(2))
! muffin-tin potential
do is=1,nspecies
nr=nrmt(is)
nri=nrmti(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
! coefficient for R_00
e00=v0-dot_product(efieldc(:),atposc(:,ia,is))
e00=e00/y00
i=1
do ir=1,nr
r=rsp(ir,is)
vclmt(i,ias)=vclmt(i,ias)+e00
vclmt(i+1,ias)=vclmt(i+1,ias)+elm(-1)*r
vclmt(i+2,ias)=vclmt(i+2,ias)+elm(0)*r
vclmt(i+3,ias)=vclmt(i+3,ias)+elm(1)*r
if (ir.le.nri) then
i=i+lmmaxi
else
i=i+lmmaxo
end if
end do
end do
end do
! interstitial potential
ir=0
do i3=0,ngridg(3)-1
v1(3)=dble(i3)/dble(ngridg(3))
do i2=0,ngridg(2)-1
v1(2)=dble(i2)/dble(ngridg(2))
do i1=0,ngridg(1)-1
v1(1)=dble(i1)/dble(ngridg(1))
ir=ir+1
call r3mv(avec,v1,v2)
vclir(ir)=vclir(ir)+v0-dot_product(efieldc(:),v2(:))
end do
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/eulerrot.f90 0000644 0000000 0000000 00000000132 13543334734 015007 x ustar 00 30 mtime=1569569244.776641851
30 atime=1569569240.962644287
30 ctime=1569569244.776641851
elk-6.3.2/src/eulerrot.f90 0000644 0025044 0025044 00000002162 13543334734 017057 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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.
!BOP
! !ROUTINE: eulerrot
! !INTERFACE:
subroutine eulerrot(ang,rot)
! !INPUT/OUTPUT PARAMETERS:
! ang : Euler angles (alpha, beta, gamma) (in,real(3))
! rot : rotation matrix (out,real(3,3))
! !DESCRIPTION:
! Given a set of Euler angles, $(\alpha,\beta,\gamma)$, this routine
! determines the corresponding $3\times 3$ rotation matrix. The so-called
! `y-convention' is taken for the Euler angles. See the routine {\tt roteuler}
! for details.
!
! !REVISION HISTORY:
! Created January 2014 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: ang(3)
real(8), intent(out) :: rot(3,3)
! local variables
real(8) sa,sb,sg,ca,cb,cg
sa=sin(ang(1)); sb=sin(ang(2)); sg=sin(ang(3))
ca=cos(ang(1)); cb=cos(ang(2)); cg=cos(ang(3))
rot(1,1)=cg*cb*ca-sg*sa
rot(1,2)=cg*cb*sa+sg*ca
rot(1,3)=-cg*sb
rot(2,1)=-sg*cb*ca-cg*sa
rot(2,2)=-sg*cb*sa+cg*ca
rot(2,3)=sg*sb
rot(3,1)=sb*ca
rot(3,2)=sb*sa
rot(3,3)=cb
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/fermisurfbxsf.f90 0000644 0000000 0000000 00000000132 13543334734 016033 x ustar 00 30 mtime=1569569244.780641848
30 atime=1569569240.967644284
30 ctime=1569569244.780641848
elk-6.3.2/src/fermisurfbxsf.f90 0000644 0025044 0025044 00000010274 13543334734 020106 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2009 F. Cricchio, F. Bultmark and L. Nordstrom.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine fermisurfbxsf
use modmain
use modomp
implicit none
! local variables
integer ik,nst,ist
integer ist0,ist1,jst0,jst1
integer i1,i2,i3,j1,j2,j3
integer nf,f,i,nthd
real(8) vc(3,0:3),e0,e1
! allocatable arrays
integer, allocatable :: idx(:)
real(8), allocatable :: evalfv(:,:),e(:)
complex(8), allocatable :: evecfv(:,:,:)
complex(8), allocatable :: evecsv(:,:)
! initialise universal variables
call init0
call init1
! read density and potentials from file
call readstate
! Fourier transform Kohn-Sham potential to G-space
call genvsig
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW and local-orbital radial functions and integrals
call genapwlofr
! generate the spin-orbit coupling radial functions
call gensocfr
! begin parallel loop over reduced k-points set
call holdthd(nkpt,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(evalfv,evecfv,evecsv) &
!$OMP NUM_THREADS(nthd)
allocate(evalfv(nstfv,nspnfv))
allocate(evecfv(nmatmax,nstfv,nspnfv))
allocate(evecsv(nstsv,nstsv))
!$OMP DO
do ik=1,nkpt
!$OMP CRITICAL(fermisurfbxsf_)
write(*,'("Info(fermisurfbxsf): ",I6," of ",I6," k-points")') ik,nkpt
!$OMP END CRITICAL(fermisurfbxsf_)
! solve the first- and second-variational eigenvalue equations
call eveqn(ik,evalfv,evecfv,evecsv)
! end loop over reduced k-points set
end do
!$OMP END DO
deallocate(evalfv,evecfv,evecsv)
!$OMP END PARALLEL
call freethd(nthd)
! if iterative diagonalisation is used the eigenvalues must be reordered
if (tefvit.and.(.not.spinpol)) then
allocate(idx(nstsv),e(nstsv))
do ik=1,nkpt
e(:)=evalsv(:,ik)
call sortidx(nstsv,e,idx)
do ist=1,nstsv
evalsv(ist,ik)=e(idx(ist))
end do
end do
deallocate(idx,e)
end if
! plotting box in Cartesian coordinates
do i=0,3
vc(:,i)=bvec(:,1)*kptboxl(1,i)+bvec(:,2)*kptboxl(2,i)+bvec(:,3)*kptboxl(3,i)
end do
! number of files to plot (2 for collinear magnetism, 1 otherwise)
if (ndmag.eq.1) then
nf=2
else
nf=1
end if
do f=1,nf
if (nf.eq.2) then
if (f.eq.1) then
open(50,file='FERMISURF_UP.bxsf',form='FORMATTED')
jst0=1; jst1=nstfv
else
open(50,file='FERMISURF_DN.bxsf',form='FORMATTED')
jst0=nstfv+1; jst1=2*nstfv
end if
else
open(50,file='FERMISURF.bxsf',form='FORMATTED')
jst0=1; jst1=nstsv
end if
! find the range of eigenvalues which contribute to the Fermi surface (Lars)
ist0=jst1; ist1=jst0
do ist=jst0,jst1
e0=minval(evalsv(ist,:)); e1=maxval(evalsv(ist,:))
! determine if the band crosses the Fermi energy
if ((e0.lt.efermi).and.(e1.gt.efermi)) then
ist0=min(ist0,ist); ist1=max(ist1,ist)
end if
end do
nst=ist1-ist0+1
write(50,'(" BEGIN_INFO")')
write(50,'(" # Band-XCRYSDEN-Structure-File for Fermi surface plotting")')
write(50,'(" # created by Elk version ",I1.1,".",I1.1,".",I2.2)') version
write(50,'(" # Launch as: xcrysden --bxsf FERMISURF(_UP/_DN).bxsf")')
write(50,'(" Fermi Energy: ",G18.10)') 0.d0
write(50,'(" END_INFO")')
write(50,'(" BEGIN_BLOCK_BANDGRID_3D")')
write(50, '(" band_energies")')
write(50,'(" BANDGRID_3D_BANDS")')
write(50,'(I4)') nst
write(50,'(3I6)') ngridk(:)+1
do i=0,3
write(50,'(3G18.10)') vc(:,i)
end do
do ist=ist0,ist1
write(50,'(" BAND: ",I4)') ist
do i1=0,ngridk(1)
j1=mod(i1,ngridk(1))
do i2=0,ngridk(2)
j2=mod(i2,ngridk(2))
do i3=0,ngridk(3)
j3=mod(i3,ngridk(3))
ik=ivkik(j1,j2,j3)
write(50,'(G18.10)') evalsv(ist,ik)-efermi
end do
end do
end do
end do
write(50,'(" END_BANDGRID_3D")')
write(50,'(" END_BLOCK_BANDGRID_3D")')
close(50)
end do
write(*,*)
write(*,'("Info(fermisurfbxsf):")')
if (ndmag.eq.1) then
write(*,'(" 3D Fermi surface data written to FERMISURF_UP.bxsf and &
&FERMISURF_DN.bxsf")')
else
write(*,'(" 3D Fermi surface data written to FERMISURF.bxsf")')
end if
write(*,'(" for plotting with XCrysDen (Fermi energy set to zero)")')
write(*,*)
write(*,'(" Launch as: xcrysden --bxsf FERMISURF(_UP/_DN).bxsf")')
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/symmetry.f90 0000644 0000000 0000000 00000000132 13543334734 015037 x ustar 00 30 mtime=1569569244.784641846
30 atime=1569569240.972644281
30 ctime=1569569244.784641846
elk-6.3.2/src/symmetry.f90 0000644 0025044 0025044 00000002054 13543334734 017107 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 symmetry
use modmain
use modvars
implicit none
! inverse of the lattice vector matrix
call r3minv(avec,ainv)
! find Bravais lattice symmetries
call findsymlat
! use only the identity if required
if (symtype.eq.0) nsymlat=1
! find the crystal symmetries and shift atomic positions if required
call findsymcrys
! find the site symmetries
call findsymsite
! check if fixed spin moments are invariant under the symmetry group
call checkfsm
! check if real symmetric first-variational eigen solver can be used
if (.not.tsyminv) tefvr=.false.
! write to VARIABLES.OUT
call writevars('nsymlat',iv=nsymlat)
call writevars('symlat',nv=9*nsymlat,iva=symlat)
call writevars('nsymcrys',iv=nsymcrys)
call writevars('vtlsymc',nv=3*nsymcrys,rva=vtlsymc)
call writevars('lsplsymc',nv=nsymcrys,iva=lsplsymc)
call writevars('lspnsymc',nv=nsymcrys,iva=lspnsymc)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/findsymcrys.f90 0000644 0000000 0000000 00000000132 13543334734 015520 x ustar 00 30 mtime=1569569244.789641843
30 atime=1569569240.977644277
30 ctime=1569569244.789641843
elk-6.3.2/src/findsymcrys.f90 0000644 0025044 0025044 00000015201 13543334734 017566 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: findsymcrys
! !INTERFACE:
subroutine findsymcrys
! !USES:
use modmain
use modmpi
use modtest
! !DESCRIPTION:
! Finds the complete set of symmetries which leave the crystal structure
! (including the magnetic fields) invariant. A crystal symmetry is of the form
! $\{\alpha_S|\alpha_R|{\bf t}\}$, where ${\bf t}$ is a translation vector,
! $\alpha_R$ is a spatial rotation operation and $\alpha_S$ is a global spin
! rotation. Note that the order of operations is important and defined to be
! from right to left, i.e. translation followed by spatial rotation followed
! by spin rotation. In the case of spin-orbit coupling $\alpha_S=\alpha_R$. In
! order to determine the translation vectors, the entire atomic basis is
! shifted so that the first atom in the smallest set of atoms of the same
! species is at the origin. Then all displacement vectors between atoms in
! this set are checked as possible symmetry translations. If the global
! variable {\tt tshift} is set to {\tt .false.} then the shift is not
! performed. See L. M. Sandratskii and P. G. Guletskii, {\it J. Phys. F: Met.
! Phys.} {\bf 16}, L43 (1986) and the routine {\tt findsym}.
!
! !REVISION HISTORY:
! Created April 2007 (JKD)
!EOP
!BOC
implicit none
! local variables
integer ia,ja,is,js
integer isym,nsym,i,n
integer lspl(48),lspn(48),ilspl
real(8) v0(3),v1(3),v2(3),t1
real(8) apl(3,maxatoms,maxspecies)
! allocatable arrays
integer, allocatable :: iea(:,:,:)
real(8), allocatable :: vtl(:,:)
! allocate local array
allocate(iea(natmmax,nspecies,48))
! allocate equivalent atom arrays
if (allocated(ieqatom)) deallocate(ieqatom)
allocate(ieqatom(natmmax,nspecies,maxsymcrys))
if (allocated(eqatoms)) deallocate(eqatoms)
allocate(eqatoms(natmmax,natmmax,nspecies))
! store position of first atom
if (natmtot.gt.0) v0(:)=atposl(:,1,1)
! find the smallest set of atoms
is=1
do js=1,nspecies
if (natoms(js).lt.natoms(is)) is=js
end do
if ((tshift).and.(natmtot.gt.0)) then
! shift basis so that the first atom in the smallest atom set is at the origin
v1(:)=atposl(:,1,is)
do js=1,nspecies
do ia=1,natoms(js)
! shift atom
atposl(:,ia,js)=atposl(:,ia,js)-v1(:)
! map lattice coordinates back to [0,1)
call r3frac(epslat,atposl(:,ia,js))
! determine the new Cartesian coordinates
call r3mv(avec,atposl(:,ia,js),atposc(:,ia,js))
end do
end do
end if
! determine possible translation vectors from smallest set of atoms
n=max(natoms(is)*natoms(is),1)
allocate(vtl(3,n))
n=1
vtl(:,1)=0.d0
do ia=1,natoms(is)
do ja=2,natoms(is)
! compute difference between two atom vectors
v1(:)=atposl(:,ia,is)-atposl(:,ja,is)
! map lattice coordinates to [0,1)
call r3frac(epslat,v1)
! check if vector has any component along electric field
if (tefield) then
call r3mv(avec,v1,v2)
t1=efieldc(1)*v2(1)+efieldc(2)*v2(2)+efieldc(3)*v2(3)
if (abs(t1).gt.epslat) goto 10
end if
do i=1,n
t1=abs(vtl(1,i)-v1(1))+abs(vtl(2,i)-v1(2))+abs(vtl(3,i)-v1(3))
if (t1.lt.epslat) goto 10
end do
n=n+1
vtl(:,n)=v1(:)
10 continue
end do
end do
! no translations required when symtype=0,2 (F. Cricchio)
if (symtype.ne.1) n=1
eqatoms(:,:,:)=.false.
nsymcrys=0
! loop over all possible translations
do i=1,n
! construct new array with translated positions
do is=1,nspecies
do ia=1,natoms(is)
apl(:,ia,is)=atposl(:,ia,is)+vtl(:,i)
end do
end do
! find the symmetries for current translation
call findsym(atposl,apl,nsym,lspl,lspn,iea)
do isym=1,nsym
nsymcrys=nsymcrys+1
if (nsymcrys.gt.maxsymcrys) then
write(*,*)
write(*,'("Error(findsymcrys): too many crystal symmetries")')
write(*,'(" Adjust maxsymcrys in modmain and recompile code")')
write(*,*)
stop
end if
vtlsymc(:,nsymcrys)=vtl(:,i)
lsplsymc(nsymcrys)=lspl(isym)
lspnsymc(nsymcrys)=lspn(isym)
do is=1,nspecies
do ia=1,natoms(is)
ja=iea(ia,is,isym)
ieqatom(ia,is,nsymcrys)=ja
eqatoms(ia,ja,is)=.true.
eqatoms(ja,ia,is)=.true.
end do
end do
end do
end do
tsyminv=.false.
do isym=1,nsymcrys
! check if inversion symmetry is present
i=lsplsymc(isym)
if (all(symlat(:,:,i).eq.-symlat(:,:,1))) then
tsyminv=.true.
! make inversion the second symmetry element (the identity is the first)
v1(:)=vtlsymc(:,isym); vtlsymc(:,isym)=vtlsymc(:,2); vtlsymc(:,2)=v1(:)
i=lsplsymc(isym); lsplsymc(isym)=lsplsymc(2); lsplsymc(2)=i
i=lspnsymc(isym); lspnsymc(isym)=lspnsymc(2); lspnsymc(2)=i
do is=1,nspecies
do ia=1,natoms(is)
i=ieqatom(ia,is,isym)
ieqatom(ia,is,isym)=ieqatom(ia,is,2)
ieqatom(ia,is,2)=i
end do
end do
goto 20
end if
end do
20 continue
! if inversion exists then shift basis so that inversion center is at origin
if (tsyminv.and.tshift) then
v1(:)=v1(:)/2.d0
do is=1,nspecies
do ia=1,natoms(is)
! shift atom
atposl(:,ia,is)=atposl(:,ia,is)+v1(:)
! map lattice coordinates back to [0,1)
call r3frac(epslat,atposl(:,ia,is))
! map lattice coordinates to [-0.5,0.5)
do i=1,3
if (atposl(i,ia,is).gt.0.5d0) atposl(i,ia,is)=atposl(i,ia,is)-1.d0
end do
! determine the new Cartesian coordinates
call r3mv(avec,atposl(:,ia,is),atposc(:,ia,is))
end do
end do
! recalculate crystal symmetry translation vectors
do isym=1,nsymcrys
ilspl=isymlat(lsplsymc(isym))
v2(:)=symlat(:,1,ilspl)*v1(1) &
+symlat(:,2,ilspl)*v1(2) &
+symlat(:,3,ilspl)*v1(3)
vtlsymc(:,isym)=vtlsymc(:,isym)-v1(:)+v2(:)
call r3frac(epslat,vtlsymc(:,isym))
end do
end if
! translation vector in Cartesian coordinates
do isym=1,nsymcrys
call r3mv(avec,vtlsymc(:,isym),vtcsymc(:,isym))
end do
! set flag for zero translation vector
do isym=1,nsymcrys
t1=abs(vtlsymc(1,isym))+abs(vtlsymc(2,isym))+abs(vtlsymc(3,isym))
if (t1.lt.epslat) then
tv0symc(isym)=.true.
else
tv0symc(isym)=.false.
end if
end do
! check inversion does not include a translation
if (tsyminv) then
if (.not.tv0symc(2)) tsyminv=.false.
end if
if (natmtot.gt.0) then
v1(:)=atposl(:,1,1)-v0(:)
t1=abs(v1(1))+abs(v1(2))+abs(v1(3))
if (mp_mpi.and.(t1.gt.epslat)) then
write(*,*)
write(*,'("Info(findsymcrys): atomic basis shift (lattice) :")')
write(*,'(3G18.10)') v1(:)
write(*,'("See GEOMETRY.OUT for new atomic positions")')
end if
end if
! write number of crystal symmetries to test file
call writetest(705,'number of crystal symmetries',iv=nsymcrys)
deallocate(iea,vtl)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/findsymsite.f90 0000644 0000000 0000000 00000000132 13543334734 015504 x ustar 00 30 mtime=1569569244.792641841
30 atime=1569569240.983644274
30 ctime=1569569244.792641841
elk-6.3.2/src/findsymsite.f90 0000644 0025044 0025044 00000001645 13543334734 017561 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 findsymsite
use modmain
implicit none
! local variables
integer is,js,ia,ja,ias
real(8) apl(3,maxatoms,maxspecies)
! automatic arrays
real(8) iea(natmmax,nspecies,48)
! allocate the site symmetry arrays
if (allocated(nsymsite)) deallocate(nsymsite)
allocate(nsymsite(natmtot))
if (allocated(lsplsyms)) deallocate(lsplsyms)
allocate(lsplsyms(48,natmtot))
if (allocated(lspnsyms)) deallocate(lspnsyms)
allocate(lspnsyms(48,natmtot))
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
do js=1,nspecies
do ja=1,natoms(js)
apl(:,ja,js)=atposl(:,ja,js)-atposl(:,ia,is)
end do
end do
call findsym(apl,apl,nsymsite(ias),lsplsyms(:,ias),lspnsyms(:,ias),iea)
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/plotpt1d.f90 0000644 0000000 0000000 00000000131 13543334734 014714 x ustar 00 30 mtime=1569569244.797641838
29 atime=1569569240.98864427
30 ctime=1569569244.797641838
elk-6.3.2/src/plotpt1d.f90 0000644 0025044 0025044 00000005243 13543334734 016770 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: plotpt1d
! !INTERFACE:
subroutine plotpt1d(cvec,nv,np,vvl,vpl,dv,dp)
! !INPUT/OUTPUT PARAMETERS:
! cvec : matrix of (reciprocal) lattice vectors stored column-wise
! (in,real(3,3))
! nv : number of vertices (in,integer)
! np : number of connecting points (in,integer)
! vvl : vertex vectors in lattice coordinates (in,real(3,nv))
! vpl : connecting point vectors in lattice coordinates (out,real(3,np))
! dv : cummulative distance to each vertex (out,real(nv))
! dp : cummulative distance to each connecting point (out,real(np))
! !DESCRIPTION:
! Generates a set of points which interpolate between a given set of vertices.
! Vertex points are supplied in lattice coordinates in the array {\tt vvl} and
! converted to Cartesian coordinates with the matrix {\tt cvec}. Interpolating
! points are stored in the array {\tt vpl}. The cummulative distances to the
! vertices and points along the path are stored in arrays {\tt dv} and
! {\tt dp}, respectively.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
! Improved September 2007 (JKD)
! Improved again, July 2010 (T. McQueen and JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: cvec(3,3)
integer, intent(in) :: nv,np
real(8), intent(in) :: vvl(3,nv)
real(8), intent(out) :: vpl(3,np),dv(nv),dp(np)
! local variables
integer i,j,k,m,n
real(8) vl(3),vc(3)
real(8) dt,f,t1
! alloctable arrays
real(8), allocatable :: seg(:)
if (nv.lt.1) then
write(*,*)
write(*,'("Error(plotpt1d): nv < 1 : ",I8)') nv
write(*,*)
stop
end if
if (np.lt.nv) then
write(*,*)
write(*,'("Error(plotpt1d): np < nv : ",2I8)') np,nv
write(*,*)
stop
end if
! special case of 1 vertex
if (nv.eq.1) then
dv(1)=0.d0
dp(:)=0.d0
do i=1,np
vpl(:,i)=vvl(:,1)
end do
return
end if
allocate(seg(nv))
! find the length of each segment and total distance
dt=0.d0
do i=1,nv-1
dv(i)=dt
vl(:)=vvl(:,i+1)-vvl(:,i)
call r3mv(cvec,vl,vc)
seg(i)=sqrt(vc(1)**2+vc(2)**2+vc(3)**2)
dt=dt+seg(i)
end do
dv(nv)=dt
! add small amount to total distance to avoid 0/0 condition
dt=dt+1.d-8
! number of points to use between vertices
n=np-nv
! construct the interpolating path
k=0
do i=1,nv-1
t1=dble(n)*seg(i)/dt
m=nint(t1)
if ((m.gt.n).or.(i.eq.(nv-1))) m=n
do j=1,m+1
k=k+1
f=dble(j-1)/dble(m+1)
dp(k)=dv(i)+f*seg(i)
vpl(:,k)=vvl(:,i)*(1.d0-f)+vvl(:,i+1)*f
end do
dt=dt-seg(i)
n=n-m
end do
dp(np)=dv(nv)
vpl(:,np)=vvl(:,nv)
deallocate(seg)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/writedos.f90 0000644 0000000 0000000 00000000132 13543334734 015006 x ustar 00 30 mtime=1569569244.801641835
30 atime=1569569240.994644267
30 ctime=1569569244.801641835
elk-6.3.2/src/writedos.f90 0000644 0025044 0025044 00000003455 13543334734 017064 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.
subroutine writedos
use modmain
implicit none
! local variables
integer ik
! initialise universal variables
call init0
call init1
! read density and potentials from file
call readstate
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! get the eigenvalues and occupancies from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
if (dosocc) call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! generate the partial and total DOS and write to file
call dos('.OUT',dosocc,occsv)
write(*,*)
write(*,'("Info(writedos):")')
write(*,'(" Total density of states written to TDOS.OUT")')
write(*,*)
write(*,'(" Partial density of states written to PDOS_Sss_Aaaaa.OUT")')
write(*,'(" for all species and atoms")')
if (dosmsum) then
write(*,'(" PDOS summed over m")')
end if
if (dosssum) then
write(*,'(" PDOS summed over spin")')
end if
write(*,*)
write(*,'(" Spin-quantisation axis : ",3G18.10)') sqados(:)
if (lmirep) then
write(*,*)
write(*,'(" Eigenvalues of a random matrix in the (l,m) basis symmetrised")')
write(*,'(" with the site symmetries written to ELMIREP.OUT for all")')
write(*,'(" species and atoms. Degenerate eigenvalues correspond to")')
write(*,'(" irreducible representations of each site symmetry group")')
end if
write(*,*)
write(*,'(" Interstitial density of states written to IDOS.OUT")')
write(*,*)
write(*,'(" Fermi energy is at zero in plots")')
write(*,*)
write(*,'(" DOS units are states/Hartree/unit cell")')
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/findprimcell.f90 0000644 0000000 0000000 00000000132 13543334734 015616 x ustar 00 30 mtime=1569569244.806641832
30 atime=1569569240.999644263
30 ctime=1569569244.806641832
elk-6.3.2/src/findprimcell.f90 0000644 0025044 0025044 00000007507 13543334734 017676 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(:),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))
! re-index external magnetic fields
bfcmt0(:,na,is)=bfcmt0(:,ia,is)
! re-index fixed spin moment vectors
mommtfix(:,na,is)=mommtfix(:,ia,is)
30 continue
end do
natoms(is)=na
end do
deallocate(dp,vp)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/proj2d.f90 0000644 0000000 0000000 00000000131 13543334734 014345 x ustar 00 30 mtime=1569569244.810641829
29 atime=1569569241.00464426
30 ctime=1569569244.810641829
elk-6.3.2/src/proj2d.f90 0000644 0025044 0025044 00000002554 13543334734 016423 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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 proj2d(np,fp)
use modmain
implicit none
! arguments
integer, intent(in) :: np
real(8), intent(inout) :: fp(np,3)
! local variables
integer i
real(8) vl1(3),vl2(3),t1,t2,t3
real(8) vc1(3),vc2(3),vc3(3),vc4(3)
! determine the 2D plotting plane vectors in Cartesian coordinates
vl1(:)=vclp2d(:,1)-vclp2d(:,0)
vl2(:)=vclp2d(:,2)-vclp2d(:,0)
call r3mv(avec,vl1,vc1)
call r3mv(avec,vl2,vc2)
! the z axis is orthogonal to the plotting plane vectors
call r3cross(vc1,vc2,vc3)
t1=sqrt(vc1(1)**2+vc1(2)**2+vc1(3)**2)
t2=sqrt(vc2(1)**2+vc2(2)**2+vc2(3)**2)
t3=sqrt(vc3(1)**2+vc3(2)**2+vc3(3)**2)
if ((t1.lt.epslat).or.(t2.lt.epslat).or.(t3.lt.epslat)) then
write(*,*)
write(*,'("Error(proj2d): degenerate 2D plotting directions")')
write(*,*)
stop
end if
! normalise the x and z axes
vc1(:)=vc1(:)/t1
vc3(:)=vc3(:)/t3
! create new y axis orthogonal to x and z axes
call r3cross(vc3,vc1,vc2)
t1=sqrt(vc2(1)**2+vc2(2)**2+vc2(3)**2)
vc2(:)=vc2(:)/t1
! project the vector function onto the orthogonalised plotting plane axes
do i=1,np
vc4(:)=fp(i,:)
fp(i,1)=dot_product(vc4(:),vc1(:))
fp(i,2)=dot_product(vc4(:),vc2(:))
fp(i,3)=dot_product(vc4(:),vc3(:))
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/nonlinopt.f90 0000644 0000000 0000000 00000000132 13543334734 015166 x ustar 00 30 mtime=1569569244.815641826
30 atime=1569569241.009644257
30 ctime=1569569244.815641826
elk-6.3.2/src/nonlinopt.f90 0000644 0025044 0025044 00000020431 13543334734 017235 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2010 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.
!BOP
! !ROUTINE: nonlinopt
! !INTERFACE:
subroutine nonlinopt
! !USES:
use modmain
use modomp
! !DESCRIPTION:
! Calculates susceptibility tensor for non-linear optical second-harmonic
! generation (SHG). The terms (ztm) are numbered according to Eqs. (49)-(51)
! of the article {\it Physica Scripta} {\bf T109}, 128 (2004). Other good
! references are {\it Phys. Rev. B} {\bf 48}, 11705 (1993) and
! {\it Phys. Rev. B} {\bf 53}, 10751 (1996).
!
! !REVISION HISTORY:
! Rewrote earlier version, June 2010 (Sharma)
!EOP
!BOC
implicit none
! local variables
integer ik,jk,ist,jst,kst
integer iw,a,b,c,l,nthd
! smallest eigenvalue difference allowed in denominator
real(8), parameter :: etol=1.d-4
real(8) eji,eki,ekj,t1
complex(8) pii(3),dji(3),vji(3),vik(3),vkj(3)
complex(8) eta,ztm(3,3),z1
character(256) fname
! allocatable arrays
real(8), allocatable :: w(:)
complex(8), allocatable :: pmat(:,:,:)
complex(8), allocatable :: chiw(:,:),chi2w(:,:)
! initialise universal variables
call init0
call init1
! read Fermi energy from file
call readfermi
! get the eigenvalues and occupancies from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! generate energy grid (starting from zero)
allocate(w(nwplot))
t1=wplot(2)/dble(nwplot)
do iw=1,nwplot
w(iw)=t1*dble(iw-1)
end do
! allocate response function arrays
allocate(chiw(nwplot,3))
allocate(chi2w(nwplot,2))
! i divided by the complex relaxation time
eta=cmplx(0.d0,swidth,8)
! begin loop over components
do l=1,noptcomp
a=optcomp(1,l)
b=optcomp(2,l)
c=optcomp(3,l)
chiw(:,:)=0.d0
chi2w(:,:)=0.d0
! parallel loop over non-reduced k-points
call holdthd(nkptnr,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(pmat,jk,ist,jst,kst) &
!$OMP PRIVATE(eji,eki,ekj,t1,z1,pii) &
!$OMP PRIVATE(dji,vji,vik,vkj,ztm,iw) &
!$OMP NUM_THREADS(nthd)
allocate(pmat(nstsv,nstsv,3))
!$OMP DO
do ik=1,nkptnr
!$OMP CRITICAL(nonlinopt_1)
write(*,'("Info(nonlinopt): ",I6," of ",I6," k-points")') ik,nkptnr
!$OMP END CRITICAL(nonlinopt_1)
! equivalent reduced k-point
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
! read momentum matrix elements from file
call getpmat(vkl(:,ik),pmat)
! scissor correct the matrix elements
do ist=1,nstsv
if (evalsv(ist,jk).lt.efermi) then
do jst=1,nstsv
if (evalsv(jst,jk).gt.efermi) then
eji=evalsv(jst,jk)-evalsv(ist,jk)
t1=(eji+scissor)/eji
pmat(ist,jst,:)=t1*pmat(ist,jst,:)
end if
end do
end if
end do
z1=(wkptnr*occmax/omega)*zi
! loop over valence states
do ist=1,nstsv
if (evalsv(ist,jk).lt.efermi) then
pii(:)=pmat(ist,ist,:)
! loop over conduction states
do jst=1,nstsv
if (evalsv(jst,jk).gt.efermi) then
eji=evalsv(jst,jk)-evalsv(ist,jk)+scissor
dji(:)=pmat(jst,jst,:)-pii(:)
vji(:)=pmat(jst,ist,:)
! loop over intermediate states
do kst=1,nstsv
if ((kst.ne.ist).and.(kst.ne.jst)) then
eki=evalsv(kst,jk)-evalsv(ist,jk)
ekj=evalsv(kst,jk)-evalsv(jst,jk)
if (evalsv(kst,jk).gt.efermi) then
eki=eki+scissor
else
ekj=ekj-scissor
end if
vik(:)=pmat(ist,kst,:)
vkj(:)=pmat(kst,jst,:)
! interband terms
t1=-eji*eki*(-ekj)*(eki+ekj)
if (abs(t1).gt.etol) then
t1=1.d0/t1
else
t1=0.d0
end if
ztm(1,1)=z1*conjg(vji(a))*(conjg(vkj(b))*conjg(vik(c)) &
+conjg(vik(b))*conjg(vkj(c)))*t1
t1=eji*(-eki)*ekj*(-eki-eji)
if (abs(t1).gt.etol) then
t1=1.d0/t1
else
t1=0.d0
end if
ztm(1,2)=0.5d0*z1*vkj(c)*(vji(a)*vik(b)+vik(a)*vji(b))*t1
t1=eji*(-eki)*ekj*(ekj-eji)
if (abs(t1).gt.etol) then
t1=1.d0/t1
else
t1=0.d0
end if
ztm(1,3)=0.5d0*z1*vik(b)*(vkj(c)*vji(a)+vji(c)*vkj(a))*t1
! intraband terms
t1=(-eki)*ekj*eji**3
if (abs(t1).gt.etol) then
t1=1.d0/t1
else
t1=0.d0
end if
ztm(2,1)=0.5d0*z1*(eki*vik(b)*(vkj(c)*vji(a)+vji(c)*vkj(a)) &
+ekj*vkj(c)*(vji(a)*vik(b)+vik(a)*vji(b)))*t1
t1=((-eji)*eki*(-ekj)*eji**2)/(-ekj-eki)
if (abs(t1).gt.etol) then
t1=1.d0/t1
else
t1=0.d0
end if
ztm(2,3)=z1*conjg(vji(a))*(conjg(vkj(b))*conjg(vik(c)) &
+conjg(vik(b))*conjg(vkj(c)))*t1
! modulation terms
t1=ekj*(-eki)*eji**3
if (abs(t1).gt.etol) then
t1=1.d0/t1
else
t1=0.d0
end if
ztm(3,1)=0.25d0*z1*(-eki)*vkj(a)*(vji(b)*vik(c)+vik(b)*vji(c))*t1
ztm(3,2)=0.25d0*z1*ekj*vik(a)*(vkj(b)*vji(c)+vji(b)*vkj(c))*t1
!$OMP CRITICAL(nonlinopt_2)
do iw=1,nwplot
! 2w interband
chi2w(iw,1)=chi2w(iw,1)+ztm(1,1)/(eji-2.d0*w(iw)+eta)
! 2w intraband
chi2w(iw,2)=chi2w(iw,2)+ztm(2,3)/(eji-2.d0*w(iw)+eta)
! w interband
chiw(iw,1)=chiw(iw,1)-(ztm(1,2)-ztm(1,3))/(eji-w(iw)+eta)
! w intraband
chiw(iw,2)=chiw(iw,2)+ztm(2,1)/(eji-w(iw)+eta)
! w modulation
chiw(iw,3)=chiw(iw,3)+(ztm(3,1)-ztm(3,2))/(eji-w(iw)+eta)
end do
!$OMP END CRITICAL(nonlinopt_2)
end if
! end loop over kst
end do
ztm(2,2)=4.d0*z1*conjg(vji(a))*(dji(b)*vji(c)+vji(b)*dji(c))/eji**4
ztm(3,3)=0.25d0*z1*vji(a)*(vji(b)*dji(c)+dji(b)*vji(c))/eji**4
!$OMP CRITICAL(nonlinopt_2)
do iw=1,nwplot
! 2w intraband
chi2w(iw,2)=chi2w(iw,2)+ztm(2,2)/(eji-2.d0*w(iw)+eta)
! w modulation
chiw(iw,3)=chiw(iw,3)+ztm(3,3)/(eji-w(iw)+eta)
end do
!$OMP END CRITICAL(nonlinopt_2)
! end loop over jst
end if
end do
! end loop over ist
end if
end do
! end loop over k-points
end do
!$OMP END DO
deallocate(pmat)
!$OMP END PARALLEL
call freethd(nthd)
! write to files
write(fname,'("CHI_INTER2w_",3I1,".OUT")') a,b,c
open(51,file=trim(fname),form='FORMATTED')
write(fname,'("CHI_INTRA2w_",3I1,".OUT")') a,b,c
open(52,file=trim(fname),form='FORMATTED')
write(fname,'("CHI_INTERw_",3I1,".OUT")') a,b,c
open(53,file=trim(fname),form='FORMATTED')
write(fname,'("CHI_INTRAw_",3I1,".OUT")') a,b,c
open(54,file=trim(fname),form='FORMATTED')
write(fname,'("CHI_",3I1,".OUT")') a,b,c
open(55,file=trim(fname),form='FORMATTED')
do iw=1,nwplot
write(51,'(2G18.10)') w(iw),dble(chi2w(iw,1))
write(52,'(2G18.10)') w(iw),dble(chi2w(iw,2))
write(53,'(2G18.10)') w(iw),dble(chiw(iw,1))
write(54,'(2G18.10)') w(iw),dble(chiw(iw,2))
t1=dble(chi2w(iw,1)+chi2w(iw,2)+chiw(iw,1)+chiw(iw,2)+chiw(iw,3))
write(55,'(2G18.10)') w(iw),t1
end do
write(51,'(" ")')
write(52,'(" ")')
write(53,'(" ")')
write(54,'(" ")')
write(55,'(" ")')
do iw=1,nwplot
write(51,'(2G18.10)') w(iw),aimag(chi2w(iw,1))
write(52,'(2G18.10)') w(iw),aimag(chi2w(iw,2))
write(53,'(2G18.10)') w(iw),aimag(chiw(iw,1))
write(54,'(2G18.10)') w(iw),aimag(chiw(iw,2))
t1=aimag(chi2w(iw,1)+chi2w(iw,2)+chiw(iw,1)+chiw(iw,2)+chiw(iw,3))
write(55,'(2G18.10)') w(iw),t1
end do
close(51); close(52); close(53); close(54); close(55)
! end loop over components
end do
write(*,*)
write(*,'("Info(nonlinopt):")')
write(*,'(" susceptibility tensor written to CHI_abc.OUT")')
write(*,'(" interband contributions written to CHI_INTERx_abc.OUT")')
write(*,'(" intraband contributions written to CHI_INTRAx_abc.OUT")')
write(*,'(" for components")')
do l=1,noptcomp
write(*,'(" a = ",I1,", b = ",I1,", c = ",I1)') optcomp(1:3,l)
end do
deallocate(w,chiw,chi2w)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/vecplot.f90 0000644 0000000 0000000 00000000132 13543334734 014622 x ustar 00 30 mtime=1569569244.819641823
30 atime=1569569241.015644253
30 ctime=1569569244.819641823
elk-6.3.2/src/vecplot.f90 0000644 0025044 0025044 00000012424 13543334734 016674 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.
!BOP
! !ROUTINE: vecplot
! !INTERFACE:
subroutine vecplot
! !DESCRIPTION:
! Outputs a 2D or 3D vector field for plotting. The vector field can be the
! magnetisation vector field, ${\bf m}$; the exchange-correlation magnetic
! field, ${\bf B}_{\rm xc}$; or the electric field
! ${\bf E}\equiv-\nabla V_{\rm C}$. The magnetisation is obtained from the
! spin density matrix, $\rho_{\alpha\beta}$, by solving
! $$ \rho_{\alpha\beta}({\bf r})=\frac{1}{2}\left(n({\bf r})
! \delta_{\alpha\beta}+\sigma\cdot {\bf m}({\bf r})\right), $$
! where $n\equiv\tr\rho_{\alpha\beta}$ is the total density. In the case of 2D
! plots, the magnetisation vectors are still 3D, but are in the coordinate
! system of the plane.
!
! !REVISION HISTORY:
! Created August 2004 (JKD)
! Included electric field plots, August 2006 (JKD)
!EOP
!BOC
use modmain
implicit none
! allocatable arrays
real(8), allocatable :: rvfmt(:,:,:),rvfir(:,:)
! initialise universal variables
call init0
if ((task.eq.72).or.(task.eq.73).or.(task.eq.82).or.(task.eq.83)) then
if (.not.spinpol) then
write(*,*)
write(*,'("Error(vecplot): spin-unpolarised magnetisation/field is zero")')
write(*,*)
stop
end if
end if
! read magnetisation and exchange-correlation magnetic field from file
call readstate
allocate(rvfmt(npmtmax,natmtot,3),rvfir(ngtot,3))
select case(task)
case(71,72,73)
! magnetisation
if (ncmag) then
! non-collinear
rvfmt(:,:,:)=magmt(:,:,:)
rvfir(:,:)=magir(:,:)
else
! collinear
rvfmt(:,:,1:2)=0.d0
rvfir(:,1:2)=0.d0
rvfmt(:,:,3)=magmt(:,:,1)
rvfir(:,3)=magir(:,1)
end if
case(81,82,83)
! exchange-correlation magnetic field
if (ncmag) then
! non-collinear
rvfmt(:,:,:)=bxcmt(:,:,:)
rvfir(:,:)=bxcir(:,:)
else
! collinear
rvfmt(:,:,1:2)=0.d0
rvfir(:,1:2)=0.d0
rvfmt(:,:,3)=bxcmt(:,:,1)
rvfir(:,3)=bxcir(:,1)
end if
case(141,142,143)
! electric field
call gradrf(vclmt,vclir,rvfmt,rvfir)
! use the negative of the gradient
rvfmt(:,:,:)=-rvfmt(:,:,:)
rvfir(:,:)=-rvfir(:,:)
case(151,152,153)
if (.not.ncmag) then
write(*,*)
write(*,'("Error(vecplot): collinear m(r) x B_xc(r) is zero")')
write(*,*)
stop
end if
call rvfcross(magmt,magir,bxcmt,bxcir,rvfmt,rvfir)
end select
select case(task)
case(71,81,141,151)
if (task.eq.71) then
open(50,file='MAG1D.OUT',form='FORMATTED')
open(51,file='MAGLINES.OUT',form='FORMATTED')
else if (task.eq.81) then
open(50,file='BXC1D.OUT',form='FORMATTED')
open(51,file='BXCLINES.OUT',form='FORMATTED')
else if (task.eq.141) then
open(50,file='EF1D.OUT',form='FORMATTED')
open(51,file='EFLINES.OUT',form='FORMATTED')
else
open(50,file='MCBXC1D.OUT',form='FORMATTED')
open(51,file='MCBXCLINES.OUT',form='FORMATTED')
end if
call plot1d(50,51,3,rvfmt,rvfir)
close(50)
write(*,*)
write(*,'("Info(vecplot):")')
if (task.eq.71) then
write(*,'(" 1D magnetisation density written to MAG1D.OUT")')
write(*,'(" vertex location lines written to MAGLINES.OUT")')
else if (task.eq.81) then
write(*,'(" 1D exchange-correlation field written to BXC1D.OUT")')
write(*,'(" vertex location lines written to BXCLINES.OUT")')
else if (task.eq.141) then
write(*,'(" 1D electric field written to EF1D.OUT")')
write(*,'(" vertex location lines written to EFLINES.OUT")')
else
write(*,'(" 1D m(r) x B_xc(r) written to MCBXC1D.OUT")')
write(*,'(" vertex location lines written to MCBXCLINES.OUT")')
end if
case(72,82,142,152)
if (task.eq.72) then
open(50,file='MAG2D.OUT',form='FORMATTED')
else if (task.eq.82) then
open(50,file='BXC2D.OUT',form='FORMATTED')
else if (task.eq.142) then
open(50,file='EF2D.OUT',form='FORMATTED')
else
open(50,file='MCBXC2D.OUT',form='FORMATTED')
end if
call plot2d(.true.,50,3,rvfmt,rvfir)
close(50)
write(*,*)
write(*,'("Info(vecplot):")')
if (task.eq.72) then
write(*,'(" 2D magnetisation density written to MAG2D.OUT")')
else if (task.eq.82) then
write(*,'(" 2D exchange-correlation field written to BXC2D.OUT")')
else if (task.eq.142) then
write(*,'(" 2D electric field written to EF2D.OUT")')
else
write(*,'(" 2D m(r) x B_xc(r) written to MCBXC2D.OUT")')
end if
write(*,'(" Note that the 3D vector field has been locally projected")')
write(*,'(" onto the 2D plotting plane axes")')
case(73,83,143,153)
if (task.eq.73) then
open(50,file='MAG3D.OUT',form='FORMATTED')
else if (task.eq.83) then
open(50,file='BXC3D.OUT',form='FORMATTED')
else if (task.eq.143) then
open(50,file='EF3D.OUT',form='FORMATTED')
else
open(50,file='MCBXC3D.OUT',form='FORMATTED')
end if
call plot3d(50,3,rvfmt,rvfir)
close(50)
write(*,*)
write(*,'("Info(vecplot):")')
if (task.eq.73) then
write(*,'(" 3D magnetisation density written to MAG3D.OUT")')
else if (task.eq.83) then
write(*,'(" 3D exchange-correlation field written to BXC3D.OUT")')
else if (task.eq.143) then
write(*,'(" 3D electric field written to EF3D.OUT")')
else
write(*,'(" 3D m(r) x B_xc(r) written to MCBXC3D.OUT")')
end if
end select
deallocate(rvfmt,rvfir)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/wfcrplot.f90 0000644 0000000 0000000 00000000130 13543334734 015004 x ustar 00 29 mtime=1569569244.82464182
30 atime=1569569241.022644249
29 ctime=1569569244.82464182
elk-6.3.2/src/wfcrplot.f90 0000644 0025044 0025044 00000002012 13543334734 017050 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.
subroutine wfcrplot
use modmain
implicit none
! local variables
integer ist,is,ia,ias,ir
character(256) fname
! initialise universal variables
call init0
! read density and potentials from file
call readstate
! generate the core wavefunctions
call gencore
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
write(fname,'("WFCORE_S",I2.2,"_A",I4.4,".OUT")') is,ia
open(50,file=trim(fname),form='FORMATTED')
do ist=1,nstsp(is)
if (spcore(ist,is)) then
do ir=1,nrsp(is)
write(50,'(2G18.10)') rsp(ir,is),rwfcr(ir,1,ist,ias)
end do
write(50,'(" ")')
end if
end do
close(50)
end do
end do
write(*,*)
write(*,'("Info(wfcrplot):")')
write(*,'(" Core state wavefunctions written to WFCORE_Sss_Aaaaa.OUT")')
write(*,'(" for all species and atoms")')
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/energykncr.f90 0000644 0000000 0000000 00000000132 13543334734 015315 x ustar 00 30 mtime=1569569244.828641818
30 atime=1569569241.027644245
30 ctime=1569569244.828641818
elk-6.3.2/src/energykncr.f90 0000644 0025044 0025044 00000002407 13543334734 017367 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007-2008 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.
subroutine energykncr
use modmain
implicit none
integer ist,is,ias
integer nr,nri,ir,i
! allocatable local arrays
real(8), allocatable :: rfmt(:)
! external functions
real(8) rfmtinp
external rfmtinp
! allocate local arrays
allocate(rfmt(npmtmax))
! calculate the kinetic energy for core states
engykncr=0.d0
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
! sum of core eigenvalues
do ist=1,nstsp(is)
if (spcore(ist,is)) engykncr=engykncr+occcr(ist,ias)*evalcr(ist,ias)
end do
! core density
rfmt(1:npmt(is))=0.d0
if (spincore) then
! spin-polarised core
i=1
do ir=1,nri
rfmt(i)=rhocr(ir,ias,1)+rhocr(ir,ias,2)
i=i+lmmaxi
end do
do ir=nri+1,nr
rfmt(i)=rhocr(ir,ias,1)+rhocr(ir,ias,2)
i=i+lmmaxo
end do
else
! spin-unpolarised core
i=1
do ir=1,nri
rfmt(i)=rhocr(ir,ias,1)
i=i+lmmaxi
end do
do ir=nri+1,nr
rfmt(i)=rhocr(ir,ias,1)
i=i+lmmaxo
end do
end if
engykncr=engykncr-rfmtinp(nr,nri,wrmt(:,is),rfmt,vsmt(:,ias))
end do
deallocate(rfmt)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/eveqnss.f90 0000644 0000000 0000000 00000000132 13543334734 014632 x ustar 00 30 mtime=1569569244.833641815
30 atime=1569569241.032644242
30 ctime=1569569244.833641815
elk-6.3.2/src/eveqnss.f90 0000644 0025044 0025044 00000014222 13543334734 016702 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 F. Bultmark, F. Cricchio, L. Nordstrom and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine eveqnss(ngp,igpig,apwalm,evalfv,evecfv,evalsvp,evecsv)
use modmain
use moddftu
use modomp
implicit none
! arguments
integer, intent(in) :: ngp(nspnfv),igpig(ngkmax,nspnfv)
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv)
real(8), intent(in) :: evalfv(nstfv,nspnfv)
complex(8), intent(in) :: evecfv(nmatmax,nstfv,nspnfv)
real(8), intent(out) :: evalsvp(nstsv)
complex(8), intent(out) :: evecsv(nstsv,nstsv)
! local variables
integer ist,jst,ispn,jspn
integer is,ia,ias,i,j,k
integer nrc,nrci,nrco
integer l,lm,nm,npc,npci
integer igp,ld,nthd
real(8) t1
real(8) ts0,ts1
complex(8) zq,z1
! allocatable arrays
complex(8), allocatable :: wfmt1(:,:,:),wfmt2(:,:),wfmt3(:),wfmt4(:,:)
complex(8), allocatable :: wfir1(:,:),wfir2(:),wfgp(:,:)
! external functions
complex(8) zdotc,zfmtinp
external zdotc,zfmtinp
if (.not.spinpol) then
write(*,*)
write(*,'("Error(eveqnss): spin-unpolarised calculation")')
write(*,*)
stop
end if
call timesec(ts0)
ld=lmmaxdm*nspinor
! zero the second-variational Hamiltonian (stored in the eigenvector array)
evecsv(:,:)=0.d0
!-------------------------!
! muffin-tin part !
!-------------------------!
allocate(wfmt1(npcmtmax,nstfv,nspnfv))
call holdthd(nstfv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfmt2,wfmt3,wfmt4) &
!$OMP PRIVATE(ias,is,ia,nrc,nrci,nrco) &
!$OMP PRIVATE(npc,npci,t1,zq,ispn,jspn) &
!$OMP PRIVATE(ist,jst,l,nm,lm,i,j,k,z1) &
!$OMP NUM_THREADS(nthd)
allocate(wfmt2(npcmtmax,nspnfv),wfmt3(npcmtmax),wfmt4(npcmtmax,3))
do ias=1,natmtot
is=idxis(ias)
ia=idxia(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
nrco=nrc-nrci
npc=npcmt(is)
npci=npcmti(is)
! de-phasing factor (FC, FB & LN)
t1=-0.5d0*dot_product(vqcss(:),atposc(:,ia,is))
zq=cmplx(cos(t1),sin(t1),8)
! compute the first-variational wavefunctions
do ispn=1,nspnfv
if (ispn.eq.2) zq=conjg(zq)
!$OMP DO
do ist=1,nstfv
call wavefmt(lradstp,ias,ngp(ispn),apwalm(:,:,:,ias,ispn), &
evecfv(:,ist,ispn),wfmt1(:,ist,ispn))
! de-phase if required
if (ssdph) wfmt1(1:npc,ist,ispn)=zq*wfmt1(1:npc,ist,ispn)
end do
!$OMP END DO
end do
!$OMP DO
do jst=1,nstfv
! convert wavefunction to spherical coordinates
do ispn=1,nspnfv
call zbsht(nrc,nrci,wfmt1(:,jst,ispn),wfmt2(:,ispn))
end do
! apply effective magnetic field and convert to spherical harmonics
wfmt3(1:npc)=bsmt(1:npc,ias,3)*wfmt2(1:npc,1)
call zfsht(nrc,nrci,wfmt3,wfmt4)
wfmt3(1:npc)=-bsmt(1:npc,ias,3)*wfmt2(1:npc,2)
call zfsht(nrc,nrci,wfmt3,wfmt4(:,2))
wfmt3(1:npc)=cmplx(bsmt(1:npc,ias,1),-bsmt(1:npc,ias,2),8)*wfmt2(1:npc,2)
call zfsht(nrc,nrci,wfmt3,wfmt4(:,3))
! apply muffin-tin potential matrix if required
if (tvmatmt) then
do l=0,lmaxdm
if (tvmmt(l,ias)) then
nm=2*l+1
lm=idxlm(l,-l)
do k=1,3
if (k.eq.1) then
ispn=1
jspn=1
else if (k.eq.2) then
ispn=2
jspn=2
else
ispn=1
jspn=2
end if
if (l.le.lmaxi) then
call zgemm('N','N',nm,nrci,nm,zone,vmatmt(lm,ispn,lm,jspn,ias), &
ld,wfmt1(lm,jst,jspn),lmmaxi,zone,wfmt4(lm,k),lmmaxi)
end if
i=npci+lm
call zgemm('N','N',nm,nrco,nm,zone,vmatmt(lm,ispn,lm,jspn,ias),ld, &
wfmt1(i,jst,jspn),lmmaxo,zone,wfmt4(i,k),lmmaxo)
end do
end if
end do
end if
! add to second-variational Hamiltonian matrix
! upper diagonal block
do ist=1,jst
z1=zfmtinp(nrc,nrci,wrcmt(:,is),wfmt1(:,ist,1),wfmt4)
evecsv(ist,jst)=evecsv(ist,jst)+z1
end do
! lower diagonal block
j=jst+nstfv
do ist=1,jst
i=ist+nstfv
z1=zfmtinp(nrc,nrci,wrcmt(:,is),wfmt1(:,ist,2),wfmt4(:,2))
evecsv(i,j)=evecsv(i,j)+z1
end do
! off-diagonal block
do ist=1,nstfv
z1=zfmtinp(nrc,nrci,wrcmt(:,is),wfmt1(:,ist,1),wfmt4(:,3))
evecsv(ist,j)=evecsv(ist,j)+z1
end do
end do
!$OMP END DO
! end loop over atoms
end do
deallocate(wfmt2,wfmt3,wfmt4)
!$OMP END PARALLEL
call freethd(nthd)
deallocate(wfmt1)
!---------------------------!
! interstitial part !
!---------------------------!
call holdthd(nstfv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfir1,wfir2,wfgp) &
!$OMP PRIVATE(ispn,igp,ist,i,j) &
!$OMP NUM_THREADS(nthd)
allocate(wfir1(ngtot,nspnfv),wfir2(ngtot),wfgp(ngkmax,3))
! begin loop over states
!$OMP DO
do jst=1,nstfv
do ispn=1,nspnfv
wfir1(:,ispn)=0.d0
do igp=1,ngp(ispn)
wfir1(igfft(igpig(igp,ispn)),ispn)=evecfv(igp,jst,ispn)
end do
! Fourier transform wavefunction to real-space
call zfftifc(3,ngridg,1,wfir1(:,ispn))
end do
! multiply with magnetic field and transform to G-space
wfir2(:)=bsir(:,3)*wfir1(:,1)
call zfftifc(3,ngridg,-1,wfir2)
do igp=1,ngp(1)
wfgp(igp,1)=wfir2(igfft(igpig(igp,1)))
end do
wfir2(:)=-bsir(:,3)*wfir1(:,2)
call zfftifc(3,ngridg,-1,wfir2)
do igp=1,ngp(2)
wfgp(igp,2)=wfir2(igfft(igpig(igp,2)))
end do
wfir2(:)=cmplx(bsir(:,1),-bsir(:,2),8)*wfir1(:,2)
call zfftifc(3,ngridg,-1,wfir2)
do igp=1,ngp(1)
wfgp(igp,3)=wfir2(igfft(igpig(igp,1)))
end do
! add to second-variational Hamiltonian matrix
! upper diagonal block
do ist=1,jst
evecsv(ist,jst)=evecsv(ist,jst)+zdotc(ngp(1),evecfv(:,ist,1),1,wfgp(:,1),1)
end do
! lower diagonal block
j=jst+nstfv
do ist=1,jst
i=ist+nstfv
evecsv(i,j)=evecsv(i,j)+zdotc(ngp(2),evecfv(:,ist,2),1,wfgp(:,2),1)
end do
! off-diagonal block
do ist=1,nstfv
evecsv(ist,j)=evecsv(ist,j)+zdotc(ngp(1),evecfv(:,ist,1),1,wfgp(:,3),1)
end do
end do
!$OMP END DO
deallocate(wfir1,wfir2,wfgp)
!$OMP END PARALLEL
call freethd(nthd)
! add the diagonal first-variational part
i=0
do ispn=1,nspinor
do ist=1,nstfv
i=i+1
evecsv(i,i)=evecsv(i,i)+evalfv(ist,ispn)
end do
end do
! diagonalise the second-variational Hamiltonian
call eveqnz(nstsv,nstsv,evecsv,evalsvp)
call timesec(ts1)
!$OMP ATOMIC
timesv=timesv+ts1-ts0
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gendmatk.f90 0000644 0000000 0000000 00000000132 13543334734 014740 x ustar 00 30 mtime=1569569244.837641812
30 atime=1569569241.037644239
30 ctime=1569569244.837641812
elk-6.3.2/src/gendmatk.f90 0000644 0025044 0025044 00000007644 13543334734 017022 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007 F. Bultmark, F. Cricchio, L. Nordstrom and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine gendmatk(tspndg,tlmdg,lmin,lmax,ias,ngp,apwalm,evecfv,evecsv,ld,dmat)
use modmain
implicit none
! arguments
logical, intent(in) :: tspndg,tlmdg
integer, intent(in) :: lmin,lmax
integer, intent(in) :: ias
integer, intent(in) :: ngp(nspnfv)
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv)
complex(8), intent(in) :: evecfv(nmatmax,nstfv,nspnfv)
complex(8), intent(in) :: evecsv(nstsv,nstsv)
integer, intent(in) :: ld
complex(8), intent(out) :: dmat(ld,nspinor,ld,nspinor,nstsv)
! local variables
integer ist,ispn,jspn,is,ia
integer nrc,nrci,irco,irc
integer l,m1,m2,lm1,lm2
integer npc,npci,i1,i2,i,j
real(8) a,b,t1
complex(8) zq(2),z1
! automatic arrays
logical done(nstfv,nspnfv)
real(8) fr1(nrcmtmax),fr2(nrcmtmax)
! allocatable arrays
complex(8), allocatable :: wfmt1(:,:,:),wfmt2(:,:)
if (lmin.lt.0) then
write(*,*)
write(*,'("Error(gendmatk): lmin < 0 : ",I8)') lmin
write(*,*)
stop
end if
if (lmax.gt.lmaxo) then
write(*,*)
write(*,'("Error(gendmatk): lmax > lmaxo : ",2I8)') lmax,lmaxo
write(*,*)
stop
end if
! allocate local arrays
allocate(wfmt1(npcmtmax,nstfv,nspnfv),wfmt2(npcmtmax,nspinor))
! species and atom numbers
is=idxis(ias)
ia=idxia(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
irco=nrci+1
npc=npcmt(is)
npci=npcmti(is)
! de-phasing factor for spin-spirals
if (ssdph) then
t1=-0.5d0*dot_product(vqcss(:),atposc(:,ia,is))
zq(1)=cmplx(cos(t1),sin(t1),8)
zq(2)=conjg(zq(1))
end if
! zero the density matrix
dmat(:,:,:,:,:)=0.d0
done(:,:)=.false.
! begin loop over second-variational states
do j=1,nstsv
if (tevecsv) then
! generate spinor wavefunction from second-variational eigenvectors
wfmt2(1:npc,:)=0.d0
i=0
do ispn=1,nspinor
jspn=jspnfv(ispn)
do ist=1,nstfv
i=i+1
z1=evecsv(i,j)
if (ssdph) z1=z1*zq(ispn)
if (abs(dble(z1))+abs(aimag(z1)).gt.epsocc) then
if (.not.done(ist,jspn)) then
call wavefmt(lradstp,ias,ngp(jspn),apwalm(:,:,:,ias,jspn), &
evecfv(:,ist,jspn),wfmt1(:,ist,jspn))
done(ist,jspn)=.true.
end if
! add to spinor wavefunction
wfmt2(1:npc,ispn)=wfmt2(1:npc,ispn)+z1*wfmt1(1:npc,ist,jspn)
end if
end do
end do
else
! spin-unpolarised wavefunction
call wavefmt(lradstp,ias,ngp,apwalm(:,:,:,ias,1),evecfv(:,j,1),wfmt2)
end if
do ispn=1,nspinor
do jspn=1,nspinor
if (tspndg.and.(ispn.ne.jspn)) cycle
do l=lmin,lmax
do m1=-l,l
lm1=idxlm(l,m1)
do m2=-l,l
lm2=idxlm(l,m2)
if (tlmdg.and.(lm1.ne.lm2)) cycle
if (l.le.lmaxi) then
i1=lm1; i2=lm2
do irc=1,nrci
z1=wfmt2(i1,ispn)*conjg(wfmt2(i2,jspn))
fr1(irc)=dble(z1); fr2(irc)=aimag(z1)
i1=i1+lmmaxi; i2=i2+lmmaxi
end do
do irc=irco,nrc
z1=wfmt2(i1,ispn)*conjg(wfmt2(i2,jspn))
fr1(irc)=dble(z1); fr2(irc)=aimag(z1)
i1=i1+lmmaxo; i2=i2+lmmaxo
end do
a=dot_product(wrcmt(1:nrc,is),fr1(1:nrc))
b=dot_product(wrcmt(1:nrc,is),fr2(1:nrc))
else
i1=npci+lm1; i2=npci+lm2
do irc=irco,nrc
z1=wfmt2(i1,ispn)*conjg(wfmt2(i2,jspn))
fr1(irc)=dble(z1); fr2(irc)=aimag(z1)
i1=i1+lmmaxo; i2=i2+lmmaxo
end do
a=dot_product(wrcmt(irco:nrc,is),fr1(irco:nrc))
b=dot_product(wrcmt(irco:nrc,is),fr2(irco:nrc))
end if
dmat(lm1,ispn,lm2,jspn,j)=cmplx(a,b,8)
end do
end do
end do
end do
end do
! end loop over second-variational states
end do
deallocate(wfmt1,wfmt2)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gensdmat.f90 0000644 0000000 0000000 00000000132 13543334734 014750 x ustar 00 30 mtime=1569569244.841641809
30 atime=1569569241.042644236
30 ctime=1569569244.841641809
elk-6.3.2/src/gensdmat.f90 0000644 0025044 0025044 00000002125 13543334734 017017 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: gensdmat
! !INTERFACE:
subroutine gensdmat(evecsv,sdmat)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! evecsv : second-variational eigenvectors (in,complex(nstsv,nstsv))
! sdmat : spin density matrices (out,complex(nspinor,nspinor,nstsv))
! !DESCRIPTION:
! Computes the spin density matrices for a set of second-variational states.
!
! !REVISION HISTORY:
! Created September 2008 (JKD)
!EOP
!BOC
implicit none
! arguments
complex(8), intent(in) :: evecsv(nstsv,nstsv)
complex(8), intent(out) :: sdmat(nspinor,nspinor,nstsv)
! local variables
integer ispn,jspn,ist,j
complex(8) z1,z2
sdmat(:,:,:)=0.d0
do j=1,nstsv
do ispn=1,nspinor
do jspn=1,nspinor
do ist=1,nstfv
z1=evecsv(ist+nstfv*(ispn-1),j)
z2=evecsv(ist+nstfv*(jspn-1),j)
sdmat(ispn,jspn,j)=sdmat(ispn,jspn,j)+z1*conjg(z2)
end do
end do
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggamt_1.f90 0000644 0000000 0000000 00000000132 13543334734 014465 x ustar 00 30 mtime=1569569244.845641807
30 atime=1569569241.048644232
30 ctime=1569569244.845641807
elk-6.3.2/src/ggamt_1.f90 0000644 0025044 0025044 00000003277 13543334734 016545 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.
!BOP
! !ROUTINE: ggamt_1
! !INTERFACE:
subroutine ggamt_1(tsh,is,np,rho,grho,g2rho,g3rho)
! !USES:
use modmain
! !DESCRIPTION:
! Spin-unpolarised version of {\tt ggamt\_sp\_1}.
!
! !REVISION HISTORY:
! Created November 2009 (JKD)
!EOP
!BOC
implicit none
! arguments
logical, intent(in) :: tsh
integer, intent(in) :: is,np
real(8), intent(in) :: rho(np)
real(8), intent(out) :: grho(np),g2rho(np),g3rho(np)
! local variables
integer nr,nri,i
! allocatable arrays
real(8), allocatable :: grfmt(:,:),gvrho(:,:),rfmt1(:),rfmt2(:)
allocate(grfmt(np,3),gvrho(np,3),rfmt2(np))
nr=nrmt(is)
nri=nrmti(is)
! |grad rho|
if (tsh) then
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rho,np,grfmt)
else
allocate(rfmt1(np))
call rfsht(nr,nri,rho,rfmt1)
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
end if
do i=1,3
call rbsht(nr,nri,grfmt(:,i),gvrho(:,i))
end do
grho(1:np)=sqrt(gvrho(1:np,1)**2+gvrho(1:np,2)**2+gvrho(1:np,3)**2)
! grad^2 rho in spherical coordinates
if (tsh) then
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rho,rfmt2)
else
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rfmt1,rfmt2)
end if
call rbsht(nr,nri,rfmt2,g2rho)
! (grad rho).(grad |grad rho|)
call rfsht(nr,nri,grho,rfmt2)
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt2,np,grfmt)
g3rho(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
g3rho(1:np)=g3rho(1:np)+gvrho(1:np,i)*rfmt2(1:np)
end do
deallocate(grfmt,gvrho,rfmt2)
if (.not.tsh) deallocate(rfmt1)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggair_1.f90 0000644 0000000 0000000 00000000132 13543334734 014457 x ustar 00 30 mtime=1569569244.850641804
30 atime=1569569241.053644229
30 ctime=1569569244.850641804
elk-6.3.2/src/ggair_1.f90 0000644 0025044 0025044 00000003077 13543334734 016535 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.
!BOP
! !ROUTINE: ggair_1
! !INTERFACE:
subroutine ggair_1(rho,grho,g2rho,g3rho)
! !USES:
use modmain
! !DESCRIPTION:
! Spin-unpolarised version of {\tt ggair\_sp\_1}.
!
! !REVISION HISTORY:
! Created November 2009 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rho(ngtot)
real(8), intent(out) :: grho(ngtot),g2rho(ngtot),g3rho(ngtot)
! local variables
integer i,ig,ifg
! allocatable arrays
real(8), allocatable :: gvrho(:,:)
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(gvrho(ngtot,3))
allocate(zfft1(ngtot),zfft2(ngtot))
zfft1(:)=rho(:)
call zfftifc(3,ngridg,-1,zfft1)
! |grad rho|
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
gvrho(:,i)=dble(zfft2(:))
end do
grho(:)=sqrt(gvrho(:,1)**2+gvrho(:,2)**2+gvrho(:,3)**2)
! grad^2 rho
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=-(gc(ig)**2)*zfft1(ifg)
end do
call zfftifc(3,ngridg,1,zfft2)
g2rho(:)=dble(zfft2(:))
! (grad rho).(grad |grad rho|)
zfft1(:)=grho(:)
call zfftifc(3,ngridg,-1,zfft1)
g3rho(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
g3rho(:)=g3rho(:)+gvrho(:,i)*dble(zfft2(:))
end do
deallocate(gvrho,zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggamt_sp_1.f90 0000644 0000000 0000000 00000000132 13543334734 015167 x ustar 00 30 mtime=1569569244.854641801
30 atime=1569569241.058644226
30 ctime=1569569244.854641801
elk-6.3.2/src/ggamt_sp_1.f90 0000644 0025044 0025044 00000010172 13543334734 017237 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: ggamt_sp_1
! !INTERFACE:
subroutine ggamt_sp_1(is,np,rhoup,rhodn,grho,gup,gdn,g2up,g2dn,g3rho,g3up,g3dn)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! is : species number (in,integer)
! np : number of muffin-tin points (in,integer)
! rhoup : spin-up density in spherical coordinates (in,real(np))
! rhodn : spin-down density (in,real(np))
! grho : |grad rho| (out,real(np))
! gup : |grad rhoup| (out,real(np))
! gdn : |grad rhodn| (out,real(np))
! g2up : grad^2 rhoup (out,real(np))
! g2dn : grad^2 rhodn (out,real(np))
! g3rho : (grad rho).(grad |grad rho|) (out,real(np))
! g3up : (grad rhoup).(grad |grad rhoup|) (out,real(np))
! g3dn : (grad rhodn).(grad |grad rhodn|) (out,real(np))
! !DESCRIPTION:
! Computes $|\nabla\rho|$, $|\nabla\rho^{\uparrow}|$,
! $|\nabla\rho^{\downarrow}|$, $\nabla^2\rho^{\uparrow}$,
! $\nabla^2\rho^{\downarrow}$, $\nabla\rho\cdot(\nabla|\nabla\rho|)$,
! $\nabla\rho^{\uparrow}\cdot(\nabla|\nabla\rho^{\uparrow}|)$ and
! $\nabla\rho^{\downarrow}\cdot(\nabla|\nabla\rho^{\downarrow}|)$
! for a muffin-tin charge density, as required by the generalised gradient
! approximation functionals of type 1 for spin-polarised densities. The input
! densities and output gradients are in terms of spherical coordinates. See
! routines {\tt potxc} and {\tt modxcifc}.
!
! !REVISION HISTORY:
! Created April 2004 (JKD)
! Simplified and improved, October 2009 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: is,np
real(8), intent(in) :: rhoup(np),rhodn(np)
real(8), intent(out) :: grho(np),gup(np),gdn(np)
real(8), intent(out) :: g2up(np),g2dn(np)
real(8), intent(out) :: g3rho(np),g3up(np),g3dn(np)
! local variables
integer nr,nri,i
! allocatable arrays
real(8), allocatable :: gvup(:,:),gvdn(:,:),grfmt(:,:)
real(8), allocatable :: rfmt1(:),rfmt2(:)
allocate(grfmt(np,3),gvup(np,3),gvdn(np,3))
allocate(rfmt1(np),rfmt2(np))
nr=nrmt(is)
nri=nrmti(is)
!----------------!
! rho up !
!----------------!
! convert rhoup to spherical harmonics
call rfsht(nr,nri,rhoup,rfmt1)
! grad rhoup in spherical coordinates
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
do i=1,3
call rbsht(nr,nri,grfmt(:,i),gvup(:,i))
end do
! |grad rhoup|
gup(1:np)=sqrt(gvup(1:np,1)**2+gvup(1:np,2)**2+gvup(1:np,3)**2)
! grad^2 rhoup in spherical coordinates
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rfmt1,rfmt2)
call rbsht(nr,nri,rfmt2,g2up)
! (grad rhoup).(grad |grad rhoup|)
call rfsht(nr,nri,gup,rfmt1)
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
g3up(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt1)
g3up(1:np)=g3up(1:np)+gvup(1:np,i)*rfmt1(1:np)
end do
!------------------!
! rho down !
!------------------!
! convert rhodn to spherical harmonics
call rfsht(nr,nri,rhodn,rfmt1)
! grad rhodn in spherical coordinates
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
do i=1,3
call rbsht(nr,nri,grfmt(:,i),gvdn(:,i))
end do
gdn(1:np)=sqrt(gvdn(1:np,1)**2+gvdn(1:np,2)**2+gvdn(1:np,3)**2)
! grad^2 rhodn in spherical coordinates
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rfmt1,rfmt2)
call rbsht(nr,nri,rfmt2,g2dn)
! (grad rhodn).(grad |grad rhodn|)
call rfsht(nr,nri,gdn,rfmt1)
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
g3dn(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt1)
g3dn(1:np)=g3dn(1:np)+gvdn(1:np,i)*rfmt1(1:np)
end do
!-------------!
! rho !
!-------------!
! |grad rho|
grho(1:np)=sqrt((gvup(1:np,1)+gvdn(1:np,1))**2 &
+(gvup(1:np,2)+gvdn(1:np,2))**2 &
+(gvup(1:np,3)+gvdn(1:np,3))**2)
! (grad rho).(grad |grad rho|)
call rfsht(nr,nri,grho,rfmt1)
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
g3rho(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt1)
g3rho(1:np)=g3rho(1:np)+(gvup(1:np,i)+gvdn(1:np,i))*rfmt1(1:np)
end do
deallocate(rfmt1,rfmt2,grfmt,gvup,gvdn)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggair_sp_1.f90 0000644 0000000 0000000 00000000132 13543334734 015161 x ustar 00 30 mtime=1569569244.858641799
30 atime=1569569241.063644222
30 ctime=1569569244.858641799
elk-6.3.2/src/ggair_sp_1.f90 0000644 0025044 0025044 00000010221 13543334734 017224 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: ggair_sp_1
! !INTERFACE:
subroutine ggair_sp_1(rhoup,rhodn,grho,gup,gdn,g2up,g2dn,g3rho,g3up,g3dn)
! !INPUT/OUTPUT PARAMETERS:
! rhoup : spin-up density (in,real(ngtot))
! rhodn : spin-down density (in,real(ngtot))
! grho : |grad rho| (out,real(ngtot))
! gup : |grad rhoup| (out,real(ngtot))
! gdn : |grad rhodn| (out,real(ngtot))
! g2up : grad^2 rhoup (out,real(ngtot))
! g2dn : grad^2 rhodn (out,real(ngtot))
! g3rho : (grad rho).(grad |grad rho|) (out,real(ngtot))
! g3up : (grad rhoup).(grad |grad rhoup|) (out,real(ngtot))
! g3dn : (grad rhodn).(grad |grad rhodn|) (out,real(ngtot))
! !DESCRIPTION:
! Computes $|\nabla\rho|$, $|\nabla\rho^{\uparrow}|$,
! $|\nabla\rho^{\downarrow}|$, $\nabla^2\rho^{\uparrow}$,
! $\nabla^2\rho^{\downarrow}$, $\nabla\rho\cdot(\nabla|\nabla\rho|)$,
! $\nabla\rho^{\uparrow}\cdot(\nabla|\nabla\rho^{\uparrow}|)$ and
! $\nabla\rho^{\downarrow}\cdot(\nabla|\nabla\rho^{\downarrow}|)$ for the
! interstitial charge density, as required by the generalised gradient
! approximation functionals of type 1 for spin-polarised densities. See
! routines {\tt potxc} and {\tt modxcifc}.
!
! !REVISION HISTORY:
! Created October 2004 (JKD)
! Simplified and improved, October 2009 (JKD)
!EOP
!BOC
use modmain
implicit none
! arguments
real(8), intent(in) :: rhoup(ngtot),rhodn(ngtot)
real(8), intent(out) :: grho(ngtot),gup(ngtot),gdn(ngtot)
real(8), intent(out) :: g2up(ngtot),g2dn(ngtot)
real(8), intent(out) :: g3rho(ngtot),g3up(ngtot),g3dn(ngtot)
! local variables
integer ig,ifg,i
! allocatable arrays
real(8), allocatable :: gvup(:,:),gvdn(:,:)
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(gvup(ngtot,3),gvdn(ngtot,3))
allocate(zfft1(ngtot),zfft2(ngtot))
!----------------!
! rho up !
!----------------!
zfft1(:)=rhoup(:)
call zfftifc(3,ngridg,-1,zfft1)
! |grad rhoup|
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
gvup(:,i)=dble(zfft2(:))
end do
gup(:)=sqrt(gvup(:,1)**2+gvup(:,2)**2+gvup(:,3)**2)
! grad^2 rhoup
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=-(gc(ig)**2)*zfft1(ifg)
end do
call zfftifc(3,ngridg,1,zfft2)
g2up(:)=dble(zfft2(:))
! (grad rhoup).(grad |grad rhoup|)
zfft1(:)=gup(:)
call zfftifc(3,ngridg,-1,zfft1)
g3up(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
g3up(:)=g3up(:)+gvup(:,i)*dble(zfft2(:))
end do
!------------------!
! rho down !
!------------------!
zfft1(:)=rhodn(:)
call zfftifc(3,ngridg,-1,zfft1)
! |grad rhodn|
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
gvdn(:,i)=dble(zfft2(:))
end do
gdn(:)=sqrt(gvdn(:,1)**2+gvdn(:,2)**2+gvdn(:,3)**2)
! grad^2 rhodn
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=-(gc(ig)**2)*zfft1(ifg)
end do
call zfftifc(3,ngridg,1,zfft2)
g2dn(:)=dble(zfft2(:))
! (grad rhodn).(grad |grad rhodn|)
zfft1(:)=gdn(:)
call zfftifc(3,ngridg,-1,zfft1)
g3dn(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
g3dn(:)=g3dn(:)+gvdn(:,i)*dble(zfft2(:))
end do
!-------------!
! rho !
!-------------!
! |grad rho|
grho(:)=sqrt((gvup(:,1)+gvdn(:,1))**2 &
+(gvup(:,2)+gvdn(:,2))**2 &
+(gvup(:,3)+gvdn(:,3))**2)
! (grad rho).(grad |grad rho|)
zfft1(:)=grho(:)
call zfftifc(3,ngridg,-1,zfft1)
g3rho(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
g3rho(:)=g3rho(:)+(gvup(:,i)+gvdn(:,i))*dble(zfft2(:))
end do
deallocate(gvup,gvdn,zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggamt_2a.f90 0000644 0000000 0000000 00000000132 13543334734 014627 x ustar 00 30 mtime=1569569244.862641796
30 atime=1569569241.068644219
30 ctime=1569569244.862641796
elk-6.3.2/src/ggamt_2a.f90 0000644 0025044 0025044 00000002734 13543334734 016704 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.
!BOP
! !ROUTINE: ggamt_2a
! !INTERFACE:
subroutine ggamt_2a(tsh,is,np,rho,g2rho,gvrho,grho2)
! !USES:
use modmain
! !DESCRIPTION:
! Spin-unpolarised version of {\tt ggamt\_sp\_2a}.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
logical, intent(in) :: tsh
integer, intent(in) :: is,np
real(8), intent(in) :: rho(np)
real(8), intent(out) :: g2rho(np),gvrho(np,3),grho2(np)
! local variables
integer nr,nri,i
! allocatable arrays
real(8), allocatable :: grfmt(:,:),rfmt1(:),rfmt2(:)
allocate(grfmt(np,3),rfmt2(np))
nr=nrmt(is)
nri=nrmti(is)
! compute grad^2 rho in spherical coordinates
if (tsh) then
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rho,rfmt2)
else
allocate(rfmt1(np))
call rfsht(nr,nri,rho,rfmt1)
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rfmt1,rfmt2)
end if
call rbsht(nr,nri,rfmt2,g2rho)
! compute grad rho in spherical coordinates
if (tsh) then
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rho,np,grfmt)
else
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
end if
do i=1,3
call rbsht(nr,nri,grfmt(:,i),gvrho(:,i))
end do
! (grad rho)^2
grho2(1:np)=gvrho(1:np,1)**2+gvrho(1:np,2)**2+gvrho(1:np,3)**2
deallocate(rfmt2,grfmt)
if (.not.tsh) deallocate(rfmt1)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggair_2a.f90 0000644 0000000 0000000 00000000132 13543334734 014621 x ustar 00 30 mtime=1569569244.866641793
30 atime=1569569241.073644216
30 ctime=1569569244.866641793
elk-6.3.2/src/ggair_2a.f90 0000644 0025044 0025044 00000002357 13543334734 016677 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.
!BOP
! !ROUTINE: ggair_2a
! !INTERFACE:
subroutine ggair_2a(rho,g2rho,gvrho,grho2)
! !USES:
use modmain
! !DESCRIPTION:
! Spin-unpolarised version of {\tt ggair\_sp\_2a}.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rho(ngtot)
real(8), intent(out) :: g2rho(ngtot),gvrho(ngtot,3),grho2(ngtot)
! local variables
integer i,ig,ifg
! allocatable arrays
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(zfft1(ngtot),zfft2(ngtot))
! Fourier transform density to G-space
zfft1(:)=rho(:)
call zfftifc(3,ngridg,-1,zfft1)
! grad^2 rho
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=-(gc(ig)**2)*zfft1(ifg)
end do
call zfftifc(3,ngridg,1,zfft2)
g2rho(:)=dble(zfft2(:))
! grad rho
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
gvrho(:,i)=dble(zfft2(:))
end do
! (grad rho)^2
grho2(:)=gvrho(:,1)**2+gvrho(:,2)**2+gvrho(:,3)**2
deallocate(zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggamt_2b.f90 0000644 0000000 0000000 00000000130 13543334734 014626 x ustar 00 29 mtime=1569569244.87164179
30 atime=1569569241.079644212
29 ctime=1569569244.87164179
elk-6.3.2/src/ggamt_2b.f90 0000644 0025044 0025044 00000003370 13543334734 016702 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.
!BOP
! !ROUTINE: ggamt_2b
! !INTERFACE:
subroutine ggamt_2b(is,np,g2rho,gvrho,vx,vc,dxdgr2,dcdgr2)
! !USES:
use modmain
! !DESCRIPTION:
! Spin-unpolarised version of {\tt ggamt\_sp\_2b}.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: is,np
real(8), intent(in) :: g2rho(np),gvrho(np,3)
real(8), intent(inout) :: vx(np),vc(np)
real(8), intent(in) :: dxdgr2(np),dcdgr2(np)
! local variables
integer nr,nri,i
! allocatable arrays
real(8), allocatable :: rfmt1(:),rfmt2(:),grfmt(:,:)
allocate(rfmt1(np),rfmt2(np),grfmt(np,3))
nr=nrmt(is)
nri=nrmti(is)
!------------------!
! exchange !
!------------------!
! convert dxdgr2 to spherical harmonics
call rfsht(nr,nri,dxdgr2,rfmt1)
! compute grad dxdgr2
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dxdgr2).(grad rho) in spherical coordinates
rfmt1(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
rfmt1(1:np)=rfmt1(1:np)+rfmt2(1:np)*gvrho(1:np,i)
end do
vx(1:np)=vx(1:np)-2.d0*(rfmt1(1:np)+dxdgr2(1:np)*g2rho(1:np))
!---------------------!
! correlation !
!---------------------!
! convert dcdgr2 to spherical harmonics
call rfsht(nr,nri,dcdgr2,rfmt1)
! compute grad dcdgr2
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dcdgr2).(grad rho) in spherical coordinates
rfmt1(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
rfmt1(1:np)=rfmt1(1:np)+rfmt2(1:np)*gvrho(1:np,i)
end do
vc(1:np)=vc(1:np)-2.d0*(rfmt1(1:np)+dcdgr2(1:np)*g2rho(1:np))
deallocate(rfmt1,rfmt2,grfmt)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggair_2b.f90 0000644 0000000 0000000 00000000131 13543334734 014621 x ustar 00 30 mtime=1569569244.875641788
29 atime=1569569241.08364421
30 ctime=1569569244.875641788
elk-6.3.2/src/ggair_2b.f90 0000644 0025044 0025044 00000003330 13543334734 016670 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.
!BOP
! !ROUTINE: ggair_2b
! !INTERFACE:
subroutine ggair_2b(g2rho,gvrho,vx,vc,dxdgr2,dcdgr2)
! !USES:
use modmain
! !DESCRIPTION:
! Spin-unpolarised version of {\tt ggair\_sp\_2b}.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: g2rho(ngtot),gvrho(ngtot,3)
real(8), intent(inout) :: vx(ngtot),vc(ngtot)
real(8), intent(in) :: dxdgr2(ngtot),dcdgr2(ngtot)
! local variables
integer ig,ifg,i
! allocatable arrays
real(8), allocatable :: rfir(:)
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(rfir(ngtot))
allocate(zfft1(ngtot),zfft2(ngtot))
!------------------!
! exchange !
!------------------!
! compute grad dxdgr2
zfft1(:)=dxdgr2(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dxdgr2).(grad rho)
rfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
rfir(:)=rfir(:)+dble(zfft2(:))*gvrho(:,i)
end do
vx(:)=vx(:)-2.d0*(rfir(:)+dxdgr2(:)*g2rho(:))
!---------------------!
! correlation !
!---------------------!
! compute grad dcdgr2
zfft1(:)=dcdgr2(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dcdgr2).(grad rho)
rfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
rfir(:)=rfir(:)+dble(zfft2(:))*gvrho(:,i)
end do
vc(:)=vc(:)-2.d0*(rfir(:)+dcdgr2(:)*g2rho(:))
deallocate(rfir,zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggamt_sp_2a.f90 0000644 0000000 0000000 00000000132 13543334734 015331 x ustar 00 30 mtime=1569569244.880641785
30 atime=1569569241.089644206
30 ctime=1569569244.880641785
elk-6.3.2/src/ggamt_sp_2a.f90 0000644 0025044 0025044 00000010325 13543334734 017401 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.
!BOP
! !ROUTINE: ggamt_sp_2a
! !INTERFACE:
subroutine ggamt_sp_2a(is,np,rhoup,rhodn,g2up,g2dn,gvup,gvdn,gup2,gdn2,gupdn)
! !USES:
use modmain
! !DESCRIPTION:
! Computes the muffin-tin gradients $\nabla^2\rho^{\uparrow}$,
! $\nabla^2\rho^{\downarrow}$, $\nabla\rho^{\uparrow}$,
! $\nabla\rho^{\downarrow}$, $(\nabla\rho^{\uparrow})^2$,
! $(\nabla\rho^{\downarrow})^2$ and
! $\nabla\rho^{\uparrow}\cdot\nabla\rho^{\downarrow}$, which are passed in to
! GGA functional subroutines of type 2. The exchange-correlation energy in
! these routines has the functional form
! $$ E_{xc}[\rho^{\uparrow},\rho^{\downarrow}]=\int d^3r\,\hat{\epsilon}_{xc}
! \bigl(\rho^{\uparrow}({\bf r}),\rho^{\downarrow}({\bf r}),
! (\nabla\rho^{\uparrow}({\bf r}))^2,(\nabla\rho^{\downarrow}({\bf r}))^2,
! \nabla\rho^{\uparrow}({\bf r})
! \cdot\nabla\rho^{\downarrow}({\bf r})\bigr), $$
! where $\hat{\epsilon}_{xc}({\bf r})=\epsilon_{xc}({\bf r})\rho({\bf r})$ is
! the xc energy per unit volume, with $\epsilon_{xc}$ being the xc energy per
! electron, and $\rho=\rho^{\uparrow}+\rho^{\downarrow}$. From the gradients
! above, type 2 GGA routines return $\epsilon_{xc}$, but not directly the xc
! potentials. Instead they generate the derivatives
! $\partial\hat{\epsilon}_{xc}/\partial\rho^{\uparrow}({\bf r})$,
! $\partial\hat{\epsilon}_{xc}/\partial(\nabla\rho^{\uparrow}({\bf r}))^2$,
! and the same for down spin, as well as
! $\partial\hat{\epsilon}_{xc}/\partial(\nabla\rho^{\uparrow}({\bf r})
! \cdot\nabla\rho^{\downarrow}({\bf r}))$. In a post-processing step invoked
! by {\tt ggamt\_sp\_2b}, integration by parts is used to obtain the xc
! potential explicitly with
! \begin{align*}
! V_{xc}^{\uparrow}({\bf r})=&\frac{\partial\hat{\epsilon}_{xc}}{\partial
! \rho^{\uparrow}({\bf r})}-2\left(\nabla\frac{\partial\hat{\epsilon}_{xc}}
! {\partial(\nabla\rho^{\uparrow})^2}\right)\cdot\nabla\rho^{\uparrow}
! -2\frac{\hat{\epsilon}_{xc}}{\partial(\nabla\rho^{\uparrow})^2}\nabla^2
! \rho^{\uparrow}\\
! &-\left(\nabla\frac{\hat{\epsilon}_{xc}}{\partial(\nabla\rho^{\uparrow}
! \cdot\nabla\rho^{\downarrow})}\right)\cdot\nabla\rho^{\downarrow}
! -\frac{\partial\hat{\epsilon}_{xc}}{\partial(\nabla\rho^{\uparrow}\cdot
! \nabla\rho^{\downarrow})}\nabla^2\rho^{\downarrow},
! \end{align*}
! and similarly for $V_{xc}^{\downarrow}$.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: is,np
real(8), intent(in) :: rhoup(np),rhodn(np)
real(8), intent(out) :: g2up(np),g2dn(np)
real(8), intent(out) :: gvup(np,3),gvdn(np,3)
real(8), intent(out) :: gup2(np),gdn2(np),gupdn(np)
! local variables
integer nr,nri,i
! allocatable arrays
real(8), allocatable :: rfmt1(:),rfmt2(:),grfmt(:,:)
allocate(rfmt1(np),rfmt2(np),grfmt(np,3))
nr=nrmt(is)
nri=nrmti(is)
!----------------!
! rho up !
!----------------!
! convert rhoup to spherical harmonics
call rfsht(nr,nri,rhoup,rfmt1)
! compute grad^2 rhoup in spherical coordinates
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rfmt1,rfmt2)
call rbsht(nr,nri,rfmt2,g2up)
! grad rhoup in spherical coordinates
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
do i=1,3
call rbsht(nr,nri,grfmt(:,i),gvup(:,i))
end do
! (grad rhoup)^2
gup2(1:np)=gvup(1:np,1)**2+gvup(1:np,2)**2+gvup(1:np,3)**2
!------------------!
! rho down !
!------------------!
! convert rhodn to spherical harmonics
call rfsht(nr,nri,rhodn,rfmt1)
! compute grad^2 rhodn in spherical coordinates
call grad2rfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rlmt(:,-2,is),rfmt1,rfmt2)
call rbsht(nr,nri,rfmt2,g2dn)
! grad rhodn in spherical coordinates
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
do i=1,3
call rbsht(nr,nri,grfmt(:,i),gvdn(:,i))
end do
! (grad rhodn)^2
gdn2(1:np)=gvdn(1:np,1)**2+gvdn(1:np,2)**2+gvdn(1:np,3)**2
! (grad rhoup).(grad rhodn)
gupdn(1:np)=gvup(1:np,1)*gvdn(1:np,1) &
+gvup(1:np,2)*gvdn(1:np,2) &
+gvup(1:np,3)*gvdn(1:np,3)
deallocate(rfmt1,rfmt2,grfmt)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggair_sp_2a.f90 0000644 0000000 0000000 00000000132 13543334734 015323 x ustar 00 30 mtime=1569569244.884641782
30 atime=1569569241.094644203
30 ctime=1569569244.884641782
elk-6.3.2/src/ggair_sp_2a.f90 0000644 0025044 0025044 00000004751 13543334734 017401 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.
!BOP
! !ROUTINE: ggair_sp_2a
! !INTERFACE:
subroutine ggair_sp_2a(rhoup,rhodn,g2up,g2dn,gvup,gvdn,gup2,gdn2,gupdn)
! !USES:
use modmain
! !DESCRIPTION:
! Computes the interstitial gradients $\nabla^2\rho^{\uparrow}$,
! $\nabla^2\rho^{\downarrow}$, $\nabla\rho^{\uparrow}$,
! $\nabla\rho^{\downarrow}$, $(\nabla\rho^{\uparrow})^2$,
! $(\nabla\rho^{\downarrow})^2$ and
! $\nabla\rho^{\uparrow}\cdot\nabla\rho^{\downarrow}$. These are used for GGA
! functionals of type 2 and meta-GGA. See {\tt ggamt\_sp\_2a} for details.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rhoup(ngtot)
real(8), intent(in) :: rhodn(ngtot)
real(8), intent(out) :: g2up(ngtot)
real(8), intent(out) :: g2dn(ngtot)
real(8), intent(out) :: gvup(ngtot,3)
real(8), intent(out) :: gvdn(ngtot,3)
real(8), intent(out) :: gup2(ngtot)
real(8), intent(out) :: gdn2(ngtot)
real(8), intent(out) :: gupdn(ngtot)
! local variables
integer ig,ifg,i
! allocatable arrays
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(zfft1(ngtot),zfft2(ngtot))
!----------------!
! rho up !
!----------------!
zfft1(:)=rhoup(:)
call zfftifc(3,ngridg,-1,zfft1)
! compute grad^2 rhoup
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=-(gc(ig)**2)*zfft1(ifg)
end do
call zfftifc(3,ngridg,1,zfft2)
g2up(:)=dble(zfft2(:))
! grad rhoup
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
gvup(:,i)=dble(zfft2(:))
end do
! (grad rhoup)^2
gup2(:)=gvup(:,1)**2+gvup(:,2)**2+gvup(:,3)**2
!------------------!
! rho down !
!------------------!
zfft1(:)=rhodn(:)
call zfftifc(3,ngridg,-1,zfft1)
! compute grad^2 rhodn
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=-(gc(ig)**2)*zfft1(ifg)
end do
call zfftifc(3,ngridg,1,zfft2)
g2dn(:)=dble(zfft2(:))
! grad rhodn
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
gvdn(:,i)=dble(zfft2(:))
end do
! (grad rhodn)^2
gdn2(:)=gvdn(:,1)**2+gvdn(:,2)**2+gvdn(:,3)**2
! (grad rhoup).(grad rhodn)
gupdn(:)=gvup(:,1)*gvdn(:,1)+gvup(:,2)*gvdn(:,2)+gvup(:,3)*gvdn(:,3)
deallocate(zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggamt_sp_2b.f90 0000644 0000000 0000000 00000000132 13543334734 015332 x ustar 00 30 mtime=1569569244.888641779
30 atime=1569569241.100644199
30 ctime=1569569244.888641779
elk-6.3.2/src/ggamt_sp_2b.f90 0000644 0025044 0025044 00000007214 13543334734 017405 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.
!BOP
! !ROUTINE: ggamt_sp_2b
! !INTERFACE:
subroutine ggamt_sp_2b(is,np,g2up,g2dn,gvup,gvdn,vxup,vxdn,vcup,vcdn,dxdgu2, &
dxdgd2,dxdgud,dcdgu2,dcdgd2,dcdgud)
! !USES:
use modmain
! !DESCRIPTION:
! Post processing step of muffin-tin gradients for GGA type 2. See routine
! {\tt ggamt\_sp\_2a} for full details.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: is,np
real(8), intent(in) :: g2up(np),g2dn(np)
real(8), intent(in) :: gvup(np,3),gvdn(np,3)
real(8), intent(inout) :: vxup(np),vxdn(np)
real(8), intent(inout) :: vcup(np),vcdn(np)
real(8), intent(in) :: dxdgu2(np),dxdgd2(np),dxdgud(np)
real(8), intent(in) :: dcdgu2(np),dcdgd2(np),dcdgud(np)
! local variables
integer nr,nri,i
! allocatable arrays
real(8), allocatable :: rfmt1(:),rfmt2(:),grfmt(:,:)
allocate(rfmt1(np),rfmt2(np),grfmt(np,3))
nr=nrmt(is)
nri=nrmti(is)
!------------------!
! exchange !
!------------------!
! convert dxdgu2 to spherical harmonics
call rfsht(nr,nri,dxdgu2,rfmt1)
! compute grad dxdgu2
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dxdgu2).(grad rhoup) in spherical coordinates
rfmt1(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
rfmt1(1:np)=rfmt1(1:np)+rfmt2(1:np)*gvup(1:np,i)
end do
vxup(1:np)=vxup(1:np)-2.d0*(rfmt1(1:np)+dxdgu2(1:np)*g2up(1:np)) &
-dxdgud(1:np)*g2dn(1:np)
! convert dxdgd2 to spherical harmonics
call rfsht(nr,nri,dxdgd2,rfmt1)
! compute grad dxdgd2
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dxdgd2).(grad rhodn) in spherical coordinates
rfmt1(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
rfmt1(1:np)=rfmt1(1:np)+rfmt2(1:np)*gvdn(1:np,i)
end do
vxdn(1:np)=vxdn(1:np)-2.d0*(rfmt1(1:np)+dxdgd2(1:np)*g2dn(1:np)) &
-dxdgud(1:np)*g2up(1:np)
! convert dxdgud to spherical harmonics
call rfsht(nr,nri,dxdgud,rfmt1)
! compute grad dxdgud
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dxdgud).(grad rhodn) and (grad dxdgud).(grad rhoup)
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt1)
vxup(1:np)=vxup(1:np)-rfmt1(1:np)*gvdn(1:np,i)
vxdn(1:np)=vxdn(1:np)-rfmt1(1:np)*gvup(1:np,i)
end do
!---------------------!
! correlation !
!---------------------!
! convert dcdgu2 to spherical harmonics
call rfsht(nr,nri,dcdgu2,rfmt1)
! compute grad dcdgu2
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dcdgu2).(grad rhoup) in spherical coordinates
rfmt1(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
rfmt1(1:np)=rfmt1(1:np)+rfmt2(1:np)*gvup(1:np,i)
end do
vcup(1:np)=vcup(1:np)-2.d0*(rfmt1(1:np)+dcdgu2(1:np)*g2up(1:np)) &
-dcdgud(1:np)*g2dn(1:np)
! convert dcdgd2 to spherical harmonics
call rfsht(nr,nri,dcdgd2,rfmt1)
! compute grad dcdgd2
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dcdgd2).(grad rhodn) in spherical coordinates
rfmt1(1:np)=0.d0
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt2)
rfmt1(1:np)=rfmt1(1:np)+rfmt2(1:np)*gvdn(1:np,i)
end do
vcdn(1:np)=vcdn(1:np)-2.d0*(rfmt1(1:np)+dcdgd2(1:np)*g2dn(1:np)) &
-dcdgud(1:np)*g2up(1:np)
! convert dcdgud to spherical harmonics
call rfsht(nr,nri,dcdgud,rfmt1)
! compute grad dcdgud
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rfmt1,np,grfmt)
! (grad dcdgud).(grad rhodn) and (grad dcdgud).(grad rhoup)
do i=1,3
call rbsht(nr,nri,grfmt(:,i),rfmt1)
vcup(1:np)=vcup(1:np)-rfmt1(1:np)*gvdn(1:np,i)
vcdn(1:np)=vcdn(1:np)-rfmt1(1:np)*gvup(1:np,i)
end do
deallocate(rfmt1,rfmt2,grfmt)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ggair_sp_2b.f90 0000644 0000000 0000000 00000000132 13543334734 015324 x ustar 00 30 mtime=1569569244.893641776
30 atime=1569569241.105644196
30 ctime=1569569244.893641776
elk-6.3.2/src/ggair_sp_2b.f90 0000644 0025044 0025044 00000007452 13543334734 017403 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.
!BOP
! !ROUTINE: ggair_sp_2b
! !INTERFACE:
subroutine ggair_sp_2b(g2up,g2dn,gvup,gvdn,vxup,vxdn,vcup,vcdn,dxdgu2,dxdgd2, &
dxdgud,dcdgu2,dcdgd2,dcdgud)
! !USES:
use modmain
! !DESCRIPTION:
! Post processing step of interstitial gradients for GGA type 2. See routine
! {\tt ggamt\_sp\_2a} for full details.
!
! !REVISION HISTORY:
! Created November 2009 (JKD and TMcQ)
!EOP
!BOC
implicit none
real(8), intent(in) :: g2up(ngtot)
real(8), intent(in) :: g2dn(ngtot)
real(8), intent(in) :: gvup(ngtot,3)
real(8), intent(in) :: gvdn(ngtot,3)
real(8), intent(inout) :: vxup(ngtot)
real(8), intent(inout) :: vxdn(ngtot)
real(8), intent(inout) :: vcup(ngtot)
real(8), intent(inout) :: vcdn(ngtot)
real(8), intent(in) :: dxdgu2(ngtot)
real(8), intent(in) :: dxdgd2(ngtot)
real(8), intent(in) :: dxdgud(ngtot)
real(8), intent(in) :: dcdgu2(ngtot)
real(8), intent(in) :: dcdgd2(ngtot)
real(8), intent(in) :: dcdgud(ngtot)
! local variables
integer ig,ifg,i
! allocatable arrays
real(8), allocatable :: rfir(:)
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(rfir(ngtot))
allocate(zfft1(ngtot),zfft2(ngtot))
!------------------!
! exchange !
!------------------!
! compute grad dxdgu2
zfft1(:)=dxdgu2(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dxdgu2).(grad rhoup)
rfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
rfir(:)=rfir(:)+dble(zfft2(:))*gvup(:,i)
end do
vxup(:)=vxup(:)-2.d0*(rfir(:)+dxdgu2(:)*g2up(:))-dxdgud(:)*g2dn(:)
! compute grad dxdgd2
zfft1(:)=dxdgd2(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dxdgd2).(grad rhodn)
rfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
rfir(:)=rfir(:)+dble(zfft2(:))*gvdn(:,i)
end do
vxdn(:)=vxdn(:)-2.d0*(rfir(:)+dxdgd2(:)*g2dn(:))-dxdgud(:)*g2up(:)
! compute grad dxdgud
zfft1(:)=dxdgud(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dxdgud).(grad rhodn) and (grad dxdgud).(grad rhoup)
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
vxup(:)=vxup(:)-dble(zfft2(:))*gvdn(:,i)
vxdn(:)=vxdn(:)-dble(zfft2(:))*gvup(:,i)
end do
!---------------------!
! correlation !
!---------------------!
! compute grad dcdgu2
zfft1(:)=dcdgu2(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dcdgu2).(grad rhoup)
rfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
rfir(:)=rfir(:)+dble(zfft2(:))*gvup(:,i)
end do
vcup(:)=vcup(:)-2.d0*(rfir(:)+dcdgu2(:)*g2up(:))-dcdgud(:)*g2dn(:)
! compute grad dcdgd2
zfft1(:)=dcdgd2(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dcdgd2).(grad rhodn)
rfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
rfir(:)=rfir(:)+dble(zfft2(:))*gvdn(:,i)
end do
vcdn(:)=vcdn(:)-2.d0*(rfir(:)+dcdgd2(:)*g2dn(:))-dcdgud(:)*g2up(:)
! compute grad dcdgud
zfft1(:)=dcdgud(:)
call zfftifc(3,ngridg,-1,zfft1)
! (grad dcdgud).(grad rhodn) and (grad dcdgud).(grad rhoup)
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
zfft2(ifg)=vgc(i,ig)*cmplx(-aimag(zfft1(ifg)),dble(zfft1(ifg)),8)
end do
call zfftifc(3,ngridg,1,zfft2)
vcup(:)=vcup(:)-dble(zfft2(:))*gvdn(:,i)
vcdn(:)=vcdn(:)-dble(zfft2(:))*gvup(:,i)
end do
deallocate(rfir,zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/genspecies.f90 0000644 0000000 0000000 00000000132 13543334734 015273 x ustar 00 30 mtime=1569569244.897641774
30 atime=1569569241.110644192
30 ctime=1569569244.897641774
elk-6.3.2/src/genspecies.f90 0000644 0025044 0025044 00000004675 13543334734 017356 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.
subroutine genspecies(fnum)
use modmain
use modmpi
implicit none
! arguments
integer, intent(in) :: fnum
! local variables
integer nz,nmax,nst,ist
integer ne,nrm,nr,ir,it,i
integer n(maxstsp),l(maxstsp),k(maxstsp)
real(8) mass,zn,t1,t2,t3
real(8) rm,rmin,rmax
real(8) occ(maxstsp),eval(maxstsp)
character(256) symb,name
! allocatable arrays
real(8), allocatable :: r(:),rho(:),vr(:),rwf(:,:,:)
read(fnum,*,err=20) nz
if (nz.le.0) then
write(*,*)
write(*,'("Error(genspecies): atomic number negative : ",I8)') nz
write(*,*)
stop
end if
read(fnum,*,err=20) symb,name
read(fnum,*,err=20) mass
! convert from 'atomic mass units' to atomic units
mass=mass*amu
read(fnum,*,err=20) rm
read(fnum,*,err=20) nst
if ((nst.le.0).or.(nst.gt.maxstsp)) then
write(*,*)
write(*,'("Error(genspecies): nst out of range : ",I8)') nst
write(*,'(" for species ",A)') trim(name)
write(*,*)
stop
end if
ne=0
nmax=1
do ist=1,nst
read(fnum,*,err=20) n(ist),l(ist),k(ist),i
ne=ne+i
occ(ist)=i
nmax=max(nmax,n(ist))
end do
if (mp_mpi) then
write(*,'("Info(genspecies): running Z = ",I4,", (",A,")")') nz,trim(name)
if (ne.ne.nz) then
write(*,*)
write(*,'("Warning(genspecies): atom not neutral, electron number : ",&
&I4)') ne
end if
end if
! nuclear charge in units of e
zn=-dble(nz)
! minimum radial mesh point proportional to 1/sqrt(Z)
rmin=2.d-6/sqrt(dble(nz))
! default effective infinity
rmax=100.d0
! set the number of radial mesh points proportional to number of nodes
nrm=100*(nmax+1)
do it=1,2
! number of points to effective infinity
t1=log(rm/rmin)
t2=log(rmax/rmin)
t3=dble(nrm)*t2/t1
nr=int(t3)
allocate(r(nr),rho(nr),vr(nr),rwf(nr,2,nst))
! generate logarithmic radial mesh
t2=t1/dble(nrm-1)
do ir=1,nr
r(ir)=rmin*exp(dble(ir-1)*t2)
end do
! solve the Kohn-Sham-Dirac equation for the atom
call atom(sol,.true.,zn,nst,n,l,k,occ,3,0,nr,r,eval,rho,vr,rwf)
! recompute the effective infinity
do ir=nr,1,-1
if (rho(ir).gt.1.d-20) then
rmax=1.75d0*r(ir)
exit
end if
end do
deallocate(r,rho,vr,rwf)
end do
! write the species file
call writespecies(symb,name,zn,mass,rmin,rm,rmax,nrm,nst,n,l,k,occ,eval)
return
20 continue
write(*,*)
write(*,'("Error(genspecies): error reading species data")')
write(*,*)
stop
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writeemd.f90 0000644 0000000 0000000 00000000132 13543334734 014766 x ustar 00 30 mtime=1569569244.901641771
30 atime=1569569241.116644189
30 ctime=1569569244.901641771
elk-6.3.2/src/writeemd.f90 0000644 0025044 0025044 00000005256 13543334734 017045 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2012 S. Dugdale, D. Ernsting and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine writeemd
use modmain
use modpw
use modmpi
use modomp
implicit none
! local variables
integer ik,ihk,recl
integer ist,ispn,nthd
real(8) sum,t1
complex(8) z1
! allocatable arrays
real(8), allocatable :: emd(:)
complex(8), allocatable :: wfpw(:,:,:)
if (spinsprl) then
write(*,*)
write(*,'("Error(writeemd): electron momentum density not available for &
&spin-spirals")')
write(*,*)
stop
end if
! initialise universal variables
call init0
call init1
call init4
! read density and potentials from file
call readstate
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! get the occupancies from file
do ik=1,nkpt
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! delete existing EMD.OUT
if (mp_mpi) then
open(160,file='EMD.OUT')
close(160,status='DELETE')
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
allocate(emd(nhkmax))
inquire(iolength=recl) vkl(:,1),nhkmax,emd
deallocate(emd)
open(160,file='EMD.OUT',form='UNFORMATTED',access='DIRECT',recl=recl)
! loop over k-points
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(emd,wfpw,ihk,sum) &
!$OMP PRIVATE(ist,ispn,z1,t1) &
!$OMP NUM_THREADS(nthd)
allocate(emd(nhkmax),wfpw(nhkmax,nspinor,nstsv))
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
!$OMP CRITICAL(writeemd_)
write(*,'("Info(writeemd): ",I6," of ",I6," k-points")') ik,nkpt
!$OMP END CRITICAL(writeemd_)
! Fourier transform the wavefunctions
call genwfpw(vkl(:,ik),ngk(1,ik),igkig(:,1,ik),vgkl(:,:,1,ik), &
vgkc(:,:,1,ik),gkc(:,1,ik),sfacgk(:,:,1,ik),nhk(1,ik),vhkc(:,:,1,ik), &
hkc(:,1,ik),sfachk(:,:,1,ik),wfpw)
! loop over all H+k-vectors
do ihk=1,nhk(1,ik)
! sum over occupied states and spins
sum=0.d0
do ist=1,nstsv
do ispn=1,nspinor
z1=wfpw(ihk,ispn,ist)
t1=dble(z1)**2+aimag(z1)**2
sum=sum+occsv(ist,ik)*t1
end do
end do
emd(ihk)=sum
end do
!$OMP CRITICAL(u160)
write(160,rec=ik) vkl(:,ik),nhk(1,ik),emd
!$OMP END CRITICAL(u160)
end do
!$OMP END DO
deallocate(emd,wfpw)
!$OMP END PARALLEL
call freethd(nthd)
close(160)
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
if (mp_mpi) then
write(*,*)
write(*,'("Info(writeemd): electron momentum density written to EMD.OUT")')
write(*,'(" for all H+k-vectors up to |H+k| < hkmax")')
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writeexpmat.f90 0000644 0000000 0000000 00000000132 13543334734 015517 x ustar 00 30 mtime=1569569244.906641768
30 atime=1569569241.121644185
30 ctime=1569569244.906641768
elk-6.3.2/src/writeexpmat.f90 0000644 0025044 0025044 00000005026 13543334734 017571 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.
subroutine writeexpmat
use modmain
implicit none
! local variables
integer nk,ik,jk,i,j
real(8) vgqc(3),gqc
real(8) a,b
! allocatable arrays
real(8), allocatable :: jlgqr(:,:)
complex(8), allocatable :: ylmgq(:),sfacgq(:)
complex(8), allocatable :: expmt(:,:),emat(:,:)
! initialise universal variables
call init0
call init1
call init2
! read in the density and potentials from file
call readstate
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! generate the phase factor function exp(iq.r) in the muffin-tins
allocate(jlgqr(njcmax,nspecies))
allocate(ylmgq(lmmaxo),sfacgq(natmtot))
allocate(expmt(npcmtmax,natmtot))
ngrf=1
call gengqrf(vecqc,vgqc,gqc,jlgqr,ylmgq,sfacgq)
call genexpmt(1,jlgqr,ylmgq,1,sfacgq,expmt)
expmt(:,:)=omega*expmt(:,:)
deallocate(jlgqr,ylmgq,sfacgq)
! number of k-points to write out
if (kstlist(1,1).le.0) then
nk=nkpt
else
nk=nkstlist
end if
open(50,file='EXPIQR.OUT',form='FORMATTED')
write(50,*)
write(50,'("q-vector (lattice coordinates) :")')
write(50,'(3G18.10)') vecql
write(50,'("q-vector (Cartesian coordinates) :")')
write(50,'(3G18.10)') vecqc
write(50,*)
write(50,'(I8," : number of k-points")') nk
write(50,'(I6," : number of states per k-point")') nstsv
allocate(emat(nstsv,nstsv))
do jk=1,nk
if (kstlist(1,1).le.0) then
ik=jk
else
ik=kstlist(1,jk)
end if
if ((ik.le.0).or.(ik.gt.nkpt)) then
write(*,*)
write(*,'("Error(writeexpiqr): k-point out of range : ",I8)') ik
write(*,*)
stop
end if
write(50,*)
write(50,'(" k-point (lattice coordinates) :")')
write(50,'(3G18.10)') vkl(:,ik)
write(50,*)
write(50,'(" k-point (Cartesian coordinates) :")')
write(50,'(3G18.10)') vkc(:,ik)
call genexpmat(vkl(:,ik),expmt,emat)
do i=1,nstsv
write(50,*)
write(50,'(I6," : state i; state j, <...>, |<...>|^2 below")') i
do j=1,nstsv
a=dble(emat(i,j))
b=aimag(emat(i,j))
write(50,'(I6,3G18.10)') j,a,b,a**2+b**2
end do
end do
! end loop over k-points
end do
close(50)
write(*,*)
write(*,'("Info(writeexpmat)")')
write(*,'(" < i,k+q | exp(iq.r) | j,k > matrix elements written to &
&EXPIQR.OUT")')
write(*,'(" for the q-vector in vecql and all k-points in kstlist")')
deallocate(expmt,emat)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rotdmat.f90 0000644 0000000 0000000 00000000132 13543334734 014620 x ustar 00 30 mtime=1569569244.911641765
30 atime=1569569241.127644182
30 ctime=1569569244.911641765
elk-6.3.2/src/rotdmat.f90 0000644 0025044 0025044 00000004736 13543334734 016701 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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 rotdmat(rspl,rspn,lmax,nspinor,ld,dmat1,dmat2)
implicit none
! arguments
real(8), intent(in) :: rspl(3,3),rspn(3,3)
integer, intent(in) :: lmax,nspinor
integer, intent(in) :: ld
complex(8), intent(in) :: dmat1(ld,nspinor,ld,nspinor)
complex(8), intent(inout) :: dmat2(ld,nspinor,ld,nspinor)
! local variables
integer lds,ispn,jspn,p
integer lmmax,l,lm1,lm2,nm
real(8), parameter :: eps=1.d-8
real(8) ang(3),angi(3)
real(8) rot(3,3),det,v(3),th
complex(8), parameter :: zzero=(0.d0,0.d0),zone=(1.d0,0.d0)
complex(8) su2(2,2),a(2,2),b(2,2)
! allocatable arrays
complex(8), allocatable :: dm(:,:,:,:),c(:,:),d(:,:)
! external functions
real(8) r3mdet
external r3mdet
lmmax=(lmax+1)**2
allocate(dm(ld,nspinor,ld,nspinor))
allocate(c(lmmax,lmmax),d(lmmax,lmmax))
! find the determinant of the spatial rotation matrix
det=r3mdet(rspl)
if (det.gt.0.d0) then
p=1
else
p=-1
end if
! make the rotation matrix proper
rot(:,:)=dble(p)*rspl(:,:)
! compute the Euler angles of the spatial rotation
call roteuler(rot,ang)
! inverse rotation: the matrix is to be rotated, not the spherical harmonics
angi(1)=-ang(3)
angi(2)=-ang(2)
angi(3)=-ang(1)
! determine the rotation matrix for complex spherical harmonics
call ylmrot(p,angi,lmax,lmmax,d)
! apply (l,m) rotation matrix as U*D*conjg(U')
lds=ld*nspinor
do ispn=1,nspinor
do jspn=1,nspinor
lm1=1
do l=0,lmax
nm=2*l+1
call zgemm('N','N',nm,lmmax,nm,zone,d(lm1,lm1),lmmax, &
dmat1(lm1,ispn,1,jspn),lds,zzero,c(lm1,1),lmmax)
lm1=lm1+nm
end do
lm1=1
do l=0,lmax
nm=2*l+1
call zgemm('N','C',lmmax,nm,nm,zone,c(1,lm1),lmmax,d(lm1,lm1),lmmax, &
zzero,dm(1,ispn,lm1,jspn),lds)
lm1=lm1+nm
end do
end do
end do
! spin rotation if required
if (nspinor.eq.2) then
! convert spin rotation matrix to axis-angle form
call rotaxang(eps,rspn,det,v,th)
! find the SU(2) representation of the rotation matrix
call axangsu2(v,th,su2)
! apply SU(2) symmetry matrix as U*D*conjg(U*) andd add to dmat2
do lm1=1,lmmax
do lm2=1,lmmax
a(:,:)=dm(lm1,:,lm2,:)
call z2mm(su2,a,b)
call z2mmct(b,su2,a)
dmat2(lm1,:,lm2,:)=dmat2(lm1,:,lm2,:)+a(:,:)
end do
end do
else
dmat2(1:lmmax,1,1:lmmax,1)=dmat2(1:lmmax,1,1:lmmax,1)+dm(1:lmmax,1,1:lmmax,1)
end if
deallocate(dm,c,d)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hrmdmat.f90 0000644 0000000 0000000 00000000132 13543334734 014602 x ustar 00 30 mtime=1569569244.915641762
30 atime=1569569241.132644178
30 ctime=1569569244.915641762
elk-6.3.2/src/hrmdmat.f90 0000644 0025044 0025044 00000001004 13543334734 016644 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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 hrmdmat(n,dmat)
implicit none
! arguments
integer, intent(in) :: n
complex(8), intent(inout) :: dmat(n,n)
! local variables
integer i,j
complex(8) z1
do i=1,n
do j=1,i-1
z1=dmat(i,j)+conjg(dmat(j,i))
dmat(i,j)=z1
dmat(j,i)=conjg(z1)
end do
dmat(i,i)=dble(dmat(i,i))
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/reademd.f90 0000644 0000000 0000000 00000000130 13543334734 014545 x ustar 00 29 mtime=1569569244.91964176
30 atime=1569569241.137644175
29 ctime=1569569244.91964176
elk-6.3.2/src/reademd.f90 0000644 0025044 0025044 00000002417 13543334734 016622 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 D. Ernsting, S. Dugdale and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine reademd(emds)
use modmain
use modpw
implicit none
! arguments
real(4), intent(out) :: emds(nhkmax,nkpt)
! local variables
integer ik,recl,nhk_
real(8) vkl_(3),t1
! allocatable arrays
real(8), allocatable :: emd(:)
allocate(emd(nhkmax))
! find the record length
inquire(iolength=recl) vkl(:,1),nhkmax,emd
open(160,file='EMD.OUT',form='UNFORMATTED',access='DIRECT',recl=recl)
do ik=1,nkpt
read(160,rec=ik) vkl_,nhk_,emd
t1=abs(vkl(1,ik)-vkl_(1))+abs(vkl(2,ik)-vkl_(2))+abs(vkl(3,ik)-vkl_(3))
if (t1.gt.epslat) then
write(*,*)
write(*,'("Error(reademd): differing vectors for k-point ",I8)') ik
write(*,'(" current : ",3G18.10)') vkl(:,ik)
write(*,'(" EMD.OUT : ",3G18.10)') vkl_
write(*,*)
stop
end if
if (nhk(1,ik).ne.nhk_) then
write(*,*)
write(*,'("Error(getpmat): differing nhk for k-point ",I8)') ik
write(*,'(" current : ",I8)') nhk(1,ik)
write(*,'(" EMD.OUT : ",I8)') nhk_
write(*,*)
stop
end if
! store momentum density in single precision array
emds(:,ik)=real(emd(:))
end do
close(160)
deallocate(emd)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/emdplot.f90 0000644 0000000 0000000 00000000132 13543334734 014612 x ustar 00 30 mtime=1569569244.923641757
30 atime=1569569241.142644172
30 ctime=1569569244.923641757
elk-6.3.2/src/emdplot.f90 0000644 0025044 0025044 00000002170 13543334734 016661 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 D. Ernsting, S. Dugdale and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine emdplot
use modmain
use modpw
implicit none
! local variables
real(8) t1
! allocatable arrays
real(4), allocatable :: emds(:,:)
t1=sum(abs(vkloff(:)))
if (t1.gt.epslat) then
write(*,*)
write(*,'("Error(emdplot): use vkloff = 0 for the ground-state run")')
write(*,*)
stop
end if
! initialise universal variables
call init0
call init1
call init4
! read in the electron momentum density
allocate(emds(nhkmax,nkpt))
call reademd(emds)
! write the density plot to file
select case(task)
case(171)
call emdplot1d(emds)
write(*,*)
write(*,'("Info(emdplot): 1D electron momentum density written to &
&EMD1D.OUT")')
case(172)
call emdplot2d(emds)
write(*,*)
write(*,'("Info(emdplot): 2D electron momentum density written to &
&EMD2D.OUT")')
case(173)
call emdplot3d(emds)
write(*,*)
write(*,'("Info(emdplot): 3D electron momentum density written to &
&EMD3D.OUT")')
end select
deallocate(emds)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rfhkintp.f90 0000644 0000000 0000000 00000000132 13543334734 014773 x ustar 00 30 mtime=1569569244.928641754
30 atime=1569569241.147644169
30 ctime=1569569244.928641754
elk-6.3.2/src/rfhkintp.f90 0000644 0025044 0025044 00000004732 13543334734 017050 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2015 D. Ernsting, S. Dugdale and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
real(8) function rfhkintp(vhpl,rfhk)
use modmain
use modpw
implicit none
! arguments
real(8), intent(in) :: vhpl(3)
real(4), intent(in) :: rfhk(nhkmax,nkpt)
! local variables
integer ivh0(3),ivk0(3),ihk
integer ivhb(3,0:1,0:1,0:1)
integer ivkb(3,0:1,0:1,0:1)
integer isym,lspl,ik,jk,i,j,k
real(8) vpl(3),fb(0:1,0:1,0:1)
real(8) f00,f01,f10,f11,f0,f1
real(8) v0(3),v1(3),v2(3),t1,t2
! find the H-vector and k-vector corresponding to the input H+p-vector
ivh0(:)=floor(vhpl(:))
vpl(:)=vhpl(:)-dble(ivh0(:))
v1(:)=vpl(:)*dble(ngridk(:))
ivk0(:)=floor(v1(:))
! determine the corners of the box containing the input point
do i=0,1; do j=0,1; do k=0,1
ivhb(:,i,j,k)=ivh0(:)
ivkb(:,i,j,k)=ivk0(:)
ivkb(1,i,j,k)=ivkb(1,i,j,k)+i
ivkb(2,i,j,k)=ivkb(2,i,j,k)+j
ivkb(3,i,j,k)=ivkb(3,i,j,k)+k
ivhb(:,i,j,k)=ivhb(:,i,j,k)+ivkb(:,i,j,k)/ngridk(:)
ivkb(:,i,j,k)=modulo(ivkb(:,i,j,k),ngridk(:))
end do; end do; end do
! determine the function at each corner of the box
do i=0,1; do j=0,1; do k=0,1
fb(i,j,k)=0.d0
! non-reduced k-point index
jk=ivkiknr(ivkb(1,i,j,k),ivkb(2,i,j,k),ivkb(3,i,j,k))
! H+k-vector at corner of box
v1(:)=dble(ivhb(:,i,j,k))+vkl(:,jk)
! store the origin of the box
if ((i.eq.0).and.(j.eq.0).and.(k.eq.0)) v0(:)=v1(:)
! vector in Cartesian coordinates
v2(:)=bvec(:,1)*v1(1)+bvec(:,2)*v1(2)+bvec(:,3)*v1(3)
! check length is within range
t1=sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
if (t1.gt.hkmax) cycle
! find the lattice symmetry which maps the non-reduced to reduced k-point
call findkpt(vkl(:,jk),isym,ik)
! index to spatial rotation in lattice point group
lspl=lsplsymc(isym)
v2(:)=symlat(1,:,lspl)*v1(1)+symlat(2,:,lspl)*v1(2)+symlat(3,:,lspl)*v1(3)
! find the H+k-vector for the reduced k-point
do ihk=1,nhk(1,ik)
t1=abs(v2(1)-vhkl(1,ihk,1,ik)) &
+abs(v2(2)-vhkl(2,ihk,1,ik)) &
+abs(v2(3)-vhkl(3,ihk,1,ik))
if (t1.lt.epslat) then
fb(i,j,k)=rfhk(ihk,ik)
exit
end if
end do
end do; end do; end do
! interpolate function
t2=(vhpl(1)-v0(1))*dble(ngridk(1))
t1=1.d0-t2
f00=fb(0,0,0)*t1+fb(1,0,0)*t2
f01=fb(0,0,1)*t1+fb(1,0,1)*t2
f10=fb(0,1,0)*t1+fb(1,1,0)*t2
f11=fb(0,1,1)*t1+fb(1,1,1)*t2
t2=(vhpl(2)-v0(2))*dble(ngridk(2))
t1=1.d0-t2
f0=f00*t1+f10*t2
f1=f01*t1+f11*t2
t2=(vhpl(3)-v0(3))*dble(ngridk(3))
t1=1.d0-t2
rfhkintp=f0*t1+f1*t2
return
end function
elk-6.3.2/src/PaxHeaders.21352/emdplot3d.f90 0000644 0000000 0000000 00000000132 13543334734 015041 x ustar 00 30 mtime=1569569244.932641751
30 atime=1569569241.153644165
30 ctime=1569569244.932641751
elk-6.3.2/src/emdplot3d.f90 0000644 0025044 0025044 00000002041 13543334734 017105 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2015 D. Ernsting, S. Dugdale and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine emdplot3d(emds)
use modmain
use modpw
use modomp
implicit none
! arguments
real(4), intent(in) :: emds(nhkmax,nkpt)
! local variables
integer np,ip,nthd
real(8) v1(3),t1
! allocatable arrays
real(8), allocatable :: vpl(:,:)
! external functions
real(8) rfhkintp
external rfhkintp
! total number of plot points
np=np3d(1)*np3d(2)*np3d(3)
! generate the 3D plotting points
allocate(vpl(3,np))
call plotpt3d(vpl)
open(50,file='EMD3D.OUT',form='FORMATTED')
write(50,'(3I6," : grid size")') np3d(:)
call holdthd(np,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(t1,v1) &
!$OMP NUM_THREADS(nthd)
!$OMP DO ORDERED
do ip=1,np
t1=rfhkintp(vpl(:,ip),emds)
call r3mv(bvec,vpl(:,ip),v1)
!$OMP ORDERED
write(50,'(4G18.10)') v1(:),t1
!$OMP END ORDERED
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
close(50)
deallocate(vpl)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/emdplot2d.f90 0000644 0000000 0000000 00000000132 13543334734 015040 x ustar 00 30 mtime=1569569244.936641749
30 atime=1569569241.158644162
30 ctime=1569569244.936641749
elk-6.3.2/src/emdplot2d.f90 0000644 0025044 0025044 00000003127 13543334734 017112 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 D. Ernsting, S. Dugdale and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine emdplot2d(emds)
use modmain
use modpw
use modomp
implicit none
! arguments
real(4), intent(in) :: emds(nhkmax,nkpt)
! local variables
integer nh(3),np,ip,n,i,nthd
real(8) vpnl(3),v1(3),t1
! allocatable arrays
real(8), allocatable :: vpl(:,:),vppc(:,:)
real(8), allocatable :: x(:),wx(:),f(:)
! external functions
real(8) rfhkintp
external rfhkintp
! allocate local arrays
np=np2d(1)*np2d(2)
allocate(vpl(3,np),vppc(2,np))
! generate the 2D plotting points
call plotpt2d(bvec,binv,vpnl,vpl,vppc)
! determine the number of integration points
nh(:)=int(hkmax*sqrt(avec(1,:)**2+avec(2,:)**2+avec(3,:)**2)/pi)+1
n=2*maxval(nh(:)*ngridk(:))
allocate(x(n),wx(n))
do i=1,n
t1=2.d0*dble(i-1)/dble(n-1)-1.d0
x(i)=t1*hkmax
end do
! determine the weights for spline integration
call wsplint(n,x,wx)
open(50,file='EMD2D.OUT',form='FORMATTED')
write(50,'(2I6," : grid size")') np2d(:)
! loop over plotting points in the 2D plane
call holdthd(np,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(f,i,v1,t1) &
!$OMP NUM_THREADS(nthd)
allocate(f(n))
!$OMP DO ORDERED
do ip=1,np
! integrate along normal to plane
do i=1,n
v1(:)=vpl(:,ip)+x(i)*vpnl(:)
f(i)=rfhkintp(v1,emds)
end do
t1=dot_product(wx(:),f(:))
!$OMP ORDERED
write(50,'(3G18.10)') vppc(1,ip),vppc(2,ip),t1
!$OMP END ORDERED
end do
!$OMP END DO
deallocate(f)
!$OMP END PARALLEL
call freethd(nthd)
close(50)
deallocate(vpl,vppc,x,wx)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/emdplot1d.f90 0000644 0000000 0000000 00000000132 13543334734 015037 x ustar 00 30 mtime=1569569244.941641746
30 atime=1569569241.162644159
30 ctime=1569569244.941641746
elk-6.3.2/src/emdplot1d.f90 0000644 0025044 0025044 00000004474 13543334734 017117 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2015 D. Ernsting, S. Dugdale and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine emdplot1d(emds)
use modmain
use modpw
use modomp
implicit none
! arguments
real(4), intent(in) :: emds(nhkmax,nkpt)
! local variables
integer nh(3),ip,n,i,j,nthd
real(8) vl1(3),vl2(3),vl3(3)
real(8) vc1(3),vc2(3),vc3(3),t1
! allocatable arrays
real(8), allocatable :: x(:),wx(:),f1(:),f2(:)
! external functions
real(8) rfhkintp
external rfhkintp
! generate the 1D plotting points: use only the first segment
call plotpt1d(bvec,2,npp1d,vvlp1d,vplp1d,dvp1d,dpp1d)
! compute two vectors orthogonal to each other and the plotting vector; these
! are the directions to be used for integration
vl1(:)=vvlp1d(:,2)-vvlp1d(:,1)
call r3mv(bvec,vl1,vc1)
t1=sqrt(vc1(1)**2+vc1(2)**2+vc1(3)**2)
if (t1.lt.epslat) then
write(*,*)
write(*,'("Error(emdplot1d): zero length plotting vector")')
write(*,*)
stop
end if
vc1(:)=vc1(:)/t1
i=1
do j=2,3
if (abs(vc1(j)).lt.abs(vc1(i))) i=j
end do
vc2(:)=0.d0
vc2(i)=1.d0
t1=dot_product(vc1,vc2)
vc2(:)=vc2(:)-t1*vc1(:)
t1=sqrt(vc2(1)**2+vc2(2)**2+vc2(3)**2)
vc2(:)=vc2(:)/t1
call r3cross(vc1,vc2,vc3)
! integration directions in lattice coordinates
call r3mv(binv,vc2,vl2)
call r3mv(binv,vc3,vl3)
! determine the number of integration points
nh(:)=int(hkmax*sqrt(avec(1,:)**2+avec(2,:)**2+avec(3,:)**2)/pi)+1
n=2*maxval(nh(:)*ngridk(:))
allocate(x(n),wx(n))
do i=1,n
t1=2.d0*dble(i-1)/dble(n-1)-1.d0
x(i)=t1*hkmax
end do
! determine the weights for spline integration
call wsplint(n,x,wx)
open(50,file='EMD1D.OUT',form='FORMATTED')
write(*,*)
! loop over plotting points along 1D line
call holdthd(npp1d,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(f1,f2,i,j,vl1,t1) &
!$OMP NUM_THREADS(nthd)
allocate(f1(n),f2(n))
!$OMP DO ORDERED
do ip=1,npp1d
do i=1,n
do j=1,n
vl1(:)=vplp1d(:,ip)+x(i)*vl2(:)+x(j)*vl3(:)
f1(j)=rfhkintp(vl1,emds)
end do
f2(i)=dot_product(wx(:),f1(:))
end do
t1=dot_product(wx(:),f2(:))
!$OMP ORDERED
write(*,'("Info(emdplot1d): done ",I6," of ",I6," points")') ip,npp1d
write(50,'(2G18.10)') dpp1d(ip),t1
flush(50)
!$OMP END ORDERED
end do
!$OMP END DO
deallocate(f1,f2)
!$OMP END PARALLEL
call freethd(nthd)
close(50)
deallocate(x,wx)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/plotpt3d.f90 0000644 0000000 0000000 00000000132 13543334734 014717 x ustar 00 30 mtime=1569569244.945641743
30 atime=1569569241.167644156
30 ctime=1569569244.945641743
elk-6.3.2/src/plotpt3d.f90 0000644 0025044 0025044 00000001431 13543334734 016765 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.
subroutine plotpt3d(vpl)
use modmain
implicit none
! arguments
real(8), intent(out) :: vpl(3,np3d(1)*np3d(2)*np3d(3))
! local variables
integer ip,i1,i2,i3
real(8) v1(3),v2(3),v3(3)
real(8) t1,t2,t3
! generate 3D grid from corner vectors
v1(:)=vclp3d(:,1)-vclp3d(:,0)
v2(:)=vclp3d(:,2)-vclp3d(:,0)
v3(:)=vclp3d(:,3)-vclp3d(:,0)
ip=0
do i3=0,np3d(3)-1
t3=dble(i3)/dble(np3d(3))
do i2=0,np3d(2)-1
t2=dble(i2)/dble(np3d(2))
do i1=0,np3d(1)-1
t1=dble(i1)/dble(np3d(1))
ip=ip+1
vpl(:,ip)=t1*v1(:)+t2*v2(:)+t3*v3(:)+vclp3d(:,0)
end do
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/plotpt2d.f90 0000644 0000000 0000000 00000000130 13543334734 014714 x ustar 00 29 mtime=1569569244.94964174
30 atime=1569569241.172644153
29 ctime=1569569244.94964174
elk-6.3.2/src/plotpt2d.f90 0000644 0025044 0025044 00000003005 13543334734 016763 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.
subroutine plotpt2d(cvec,cinv,vpnl,vpl,vppc)
use modmain
implicit none
! arguments
real(8), intent(in) :: cvec(3,3),cinv(3,3)
real(8), intent(out) :: vpnl(3)
real(8), intent(out) :: vpl(3,np2d(1)*np2d(2))
real(8), intent(out) :: vppc(2,np2d(1)*np2d(2))
! local variables
integer ip,i1,i2
real(8) vl1(3),vl2(3)
real(8) vc1(3),vc2(3),vc3(3)
real(8) d1,d2,d12,t1,t2
vl1(:)=vclp2d(:,1)-vclp2d(:,0)
vl2(:)=vclp2d(:,2)-vclp2d(:,0)
call r3mv(cvec,vl1,vc1)
call r3mv(cvec,vl2,vc2)
d1=sqrt(vc1(1)**2+vc1(2)**2+vc1(3)**2)
d2=sqrt(vc2(1)**2+vc2(2)**2+vc2(3)**2)
if ((d1.lt.epslat).or.(d2.lt.epslat)) then
write(*,*)
write(*,'("Error(plotpt2d): zero length plotting vectors")')
write(*,*)
stop
end if
d12=(vc1(1)*vc2(1)+vc1(2)*vc2(2)+vc1(3)*vc2(3))/(d1*d2)
! vector normal to plane
call r3cross(vc1,vc2,vc3)
t1=sqrt(vc3(1)**2+vc3(2)**2+vc3(3)**2)
if (t1.lt.epslat) then
write(*,*)
write(*,'("Error(plotpt2d): 2D plotting plane vectors are collinear")')
write(*,*)
stop
end if
vc3(:)=vc3(:)/t1
call r3mv(cinv,vc3,vpnl)
ip=0
do i2=0,np2d(2)-1
do i1=0,np2d(1)-1
ip=ip+1
t1=dble(i1)/dble(np2d(1))
t2=dble(i2)/dble(np2d(2))
! plot points in 3D space
vpl(:,ip)=t1*vl1(:)+t2*vl2(:)+vclp2d(:,0)
! plot points on the plane
vppc(1,ip)=t1*d1+t2*d2*d12
vppc(2,ip)=t2*d2*sqrt(abs(1.d0-d12**2))
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writeevsp.f90 0000644 0000000 0000000 00000000132 13543334734 015176 x ustar 00 30 mtime=1569569244.954641737
30 atime=1569569241.178644149
30 ctime=1569569244.954641737
elk-6.3.2/src/writeevsp.f90 0000644 0025044 0025044 00000002000 13543334734 017235 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.
subroutine writeevsp
use modmain
implicit none
! local variables
integer is,ist
! solve the atomic Dirac-Kohn-Sham ground state for all species
call init0
! write out the atomic eigenvalues for each species
open(50,file='EVALSP.OUT',form='FORMATTED')
write(50,*)
write(50,'("Kohn-Sham-Dirac eigenvalues for all atomic species")')
write(50,*)
write(50,'("Exchange-correlation functional : ",3I6)') xctsp(:)
do is=1,nspecies
write(50,*)
write(50,'("Species : ",I4," (",A,")",I4)') is,trim(spsymb(is))
do ist=1,nstsp(is)
write(50,'(" n = ",I2,", l = ",I2,", k = ",I2," : ",G18.10)') nsp(ist,is), &
lsp(ist,is),ksp(ist,is),evalsp(ist,is)
end do
end do
close(50)
write(*,*)
write(*,'("Info(writeevsp)")')
write(*,'(" Kohn-Sham-Dirac eigenvalues written to EVALSP.OUT for all atomic &
&species")')
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/torque.f90 0000644 0000000 0000000 00000000132 13543334734 014465 x ustar 00 30 mtime=1569569244.958641735
30 atime=1569569241.184644145
30 ctime=1569569244.958641735
elk-6.3.2/src/torque.f90 0000644 0025044 0025044 00000001730 13543334734 016535 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 torque
use modmain
implicit none
! local variables
integer idm
real(8) torq(3)
! allocatable arrays
real(8), allocatable :: rvfmt(:,:,:),rvfir(:,:)
! external functions
real(8) rfint
external rfint
! initialise universal variables
call init0
if (.not.ncmag) then
torq(:)=0.d0
goto 10
end if
! read magnetisation and exchange-correlation magnetic field from file
call readstate
! compute m(r) x B_xc(r)
allocate(rvfmt(npmtmax,natmtot,3),rvfir(ngtot,3))
call rvfcross(magmt,magir,bxcmt,bxcir,rvfmt,rvfir)
! integrate to find the total torque
do idm=1,ndmag
torq(idm)=rfint(rvfmt(:,:,idm),rvfir(:,idm))
end do
10 continue
write(*,*)
write(*,'("Info(torque):")')
write(*,'(" Total torque exerted by B_xc on the magnetisation :")')
write(*,'(3G18.10)') torq
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/ssfsmjx.f90 0000644 0000000 0000000 00000000132 13543334734 014643 x ustar 00 30 mtime=1569569244.962641732
30 atime=1569569241.189644142
30 ctime=1569569244.962641732
elk-6.3.2/src/ssfsmjx.f90 0000644 0025044 0025044 00000004046 13543334734 016716 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 A. Jakobsson.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine ssfsmjx
use modmain
use modjx
use modrandom
use modstore
use modmpi
implicit none
! local variables
integer iq,i
integer is,ia,ias
real(8) tp(2),t1
! initialise universal variables
call init0
! store original variables
bfcmt0_(:,:,:)=bfcmt0(:,:,:)
spinsprl_=spinsprl
vqlss_(:)=vqlss(:)
! enable spin-spirals
spinsprl=.true.
! enable fixed spin direction
fsmtype=-2
! open SSFSMJX.OUT
if (mp_mpi) then
open(71,file='SSFSMJX.OUT',form='FORMATTED')
end if
! loop over spin-spiral q-vectors
do iq=1,nqssjx
if (mp_mpi) then
write(*,'("Info(ssfsmjx): spin-spiral q-vector ",I6," of ",I6)') iq,nqssjx
end if
! generate random q-vector
do i=1,3
vqlss(i)=2.d0*randomu()-1.d0
end do
! generate random fixed spin moment directions for those atoms with non-zero
! external magnetic fields
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
tp(1)=thssjx(1)+(thssjx(2)-thssjx(1))*randomu()
tp(2)=twopi*randomu()
t1=bfcmt0_(3,ia,is)
mommtfix(1,ia,is)=t1*sin(tp(1))*cos(tp(2))
mommtfix(2,ia,is)=t1*sin(tp(1))*sin(tp(2))
mommtfix(3,ia,is)=t1*cos(tp(1))
bfcmt0(:,ia,is)=-mommtfix(:,ia,is)
end do
end do
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
! run the ground-state spin-spiral calculation
call gndstate
! write data to file
if (mp_mpi) then
write(71,*)
write(71,'(3G18.10)') vqlss(:)
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
t1=sqrt(sum(mommt(:,ias)**2))
t1=-sign(t1,bfcmt0(3,ia,is))
write(71,'(6G18.10)') tp(:),bfsmcmt(:,ias),t1
end do
end do
flush(71)
end if
end do
close(71)
if (mp_mpi) then
write(*,*)
write(*,'("Info(ssfsmjx):")')
write(*,'(" Spin-spiral fixed spin moment data written to SSFSMJX.OUT")')
end if
! restore original input parameters
bfcmt0(:,:,:)=bfcmt0_(:,:,:)
spinsprl=spinsprl_
vqlss(:)=vqlss_(:)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/wxcplot.f90 0000644 0000000 0000000 00000000132 13543334734 014646 x ustar 00 30 mtime=1569569244.967641729
30 atime=1569569241.195644138
30 ctime=1569569244.967641729
elk-6.3.2/src/wxcplot.f90 0000644 0025044 0025044 00000002502 13543334734 016714 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 wxcplot
use modmain
implicit none
! initialise universal variables
call init0
if (xcgrad.ne.4) then
write(*,*)
write(*,'("Error(wxcplot): tau-DFT not in use")')
write(*,*)
stop
end if
! read the density and potentials from file
call readstate
! write the potential plots to file
select case(task)
case(341)
open(50,file='WXC1D.OUT',form='FORMATTED')
open(51,file='WLINES.OUT',form='FORMATTED')
call plot1d(50,51,1,wxcmt,wxcir)
close(50)
close(51)
write(*,*)
write(*,'("Info(wxcplot):")')
write(*,'(" 1D tau-DFT exchange-correlation potential written to WXC1D.OUT")')
write(*,'(" vertex location lines written to WLINES.OUT")')
case(342)
open(50,file='WXC2D.OUT',form='FORMATTED')
call plot2d(.false.,50,1,wxcmt,wxcir)
close(50)
write(*,*)
write(*,'("Info(wxcplot):")')
write(*,'(" 2D tau-DFT exchange-correlation potential written to WXC2D.OUT")')
case(343)
open(50,file='WXC3D.OUT',form='FORMATTED')
call plot3d(50,1,wxcmt,wxcir)
close(50)
write(*,*)
write(*,'("Info(wxcplot):")')
write(*,'(" 3D tau-DFTexchange-correlation potential written to WXC3D.OUT")')
end select
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/effmass.f90 0000644 0000000 0000000 00000000132 13543334734 014572 x ustar 00 30 mtime=1569569244.971641726
30 atime=1569569241.200644135
30 ctime=1569569244.971641726
elk-6.3.2/src/effmass.f90 0000644 0025044 0025044 00000011340 13543334734 016640 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 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.
subroutine effmass
use modmain
use modomp
use modtest
implicit none
! local variables
integer ik0,ik,ist,info
integer i,j,k,l,m,n,nthd
integer i1,i2,i3,j1,j2,j3
real(8) d(3,3),em(3,3)
real(8) v1(3),v2(3)
real(8) w(3),work(9)
! allocatable arrays
integer, allocatable :: ipiv(:)
real(8), allocatable :: a(:,:),b(:,:,:,:),c(:,:,:)
real(8), allocatable :: evalfv(:,:)
complex(8), allocatable :: evecfv(:,:,:),evecsv(:,:)
! initialise universal variables
call init0
call init1
allocate(ipiv(nkpt))
allocate(a(nkpt,nkpt))
n=2*ndspem+1
allocate(b(0:n-1,0:n-1,0:n-1,nstsv))
allocate(c(0:n-1,0:n-1,0:n-1))
! read density and potentials from file
call readstate
! Fourier transform Kohn-Sham potential to G-space
call genvsig
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW and local-orbital radial functions and integrals
call genapwlofr
! generate the spin-orbit coupling radial functions
call gensocfr
ik0=0
! begin parallel loop over k-points
call holdthd(nkpt,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(evalfv,evecfv,evecsv) &
!$OMP PRIVATE(i1,i2,i3,j1,j2,j3,ist) &
!$OMP NUM_THREADS(nthd)
allocate(evalfv(nstfv,nspnfv))
allocate(evecfv(nmatmax,nstfv,nspnfv))
allocate(evecsv(nstsv,nstsv))
!$OMP DO
do ik=1,nkpt
i1=ivk(1,ik); i2=ivk(2,ik); i3=ivk(3,ik)
if ((i1.eq.0).and.(i2.eq.0).and.(i3.eq.0)) ik0=ik
! solve the first- and second-variational eigenvalue equations
call eveqn(ik,evalfv,evecfv,evecsv)
! copy eigenvalues to new array
j1=i1+ndspem; j2=i2+ndspem; j3=i3+ndspem
do ist=1,nstsv
b(j1,j2,j3,ist)=evalsv(ist,ik)
end do
end do
!$OMP END DO
deallocate(evalfv,evecfv,evecsv)
!$OMP END PARALLEL
call freethd(nthd)
! set up polynomial matrix
i=0
do i3=-ndspem,ndspem
do i2=-ndspem,ndspem
do i1=-ndspem,ndspem
i=i+1
v1(1)=dble(i1); v1(2)=dble(i2); v1(3)=dble(i3)
v1(:)=v1(:)*deltaem
j=0
v2(3)=1.d0
do j3=0,n-1
v2(2)=1.d0
do j2=0,n-1
v2(1)=1.d0
do j1=0,n-1
j=j+1
a(i,j)=v2(1)*v2(2)*v2(3)
v2(1)=v2(1)*v1(1)
end do
v2(2)=v2(2)*v1(2)
end do
v2(3)=v2(3)*v1(3)
end do
end do
end do
end do
! solve for the polynomial coefficients
call dgesv(nkpt,nstsv,a,nkpt,ipiv,b,nkpt,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(effmass): could not determine polynomial coefficients")')
write(*,'(" DGESV returned INFO = ",I8)') info
write(*,*)
stop
end if
open(50,file='EFFMASS.OUT',form='FORMATTED')
write(50,*)
write(50,'("(effective mass matrices are in Cartesian coordinates)")')
write(50,*)
write(50,'("k-point (lattice coordinates) :")')
write(50,'(3G18.10)') vklem
write(50,*)
write(50,'("k-point (Cartesian coordinates) :")')
call r3mv(bvec,vklem,v1)
write(50,'(3G18.10)') v1
! begin loop over states
do ist=1,nstsv
! compute matrix of derivatives with respect to k-vector
do k=1,3
do l=1,3
c(:,:,:)=b(:,:,:,ist)
do i=1,2
if (i.eq.1) then
m=k
else
m=l
end if
if (m.eq.1) then
do j=0,n-2
c(j,:,:)=dble(j+1)*c(j+1,:,:)
end do
c(n-1,:,:)=0.d0
else if (m.eq.2) then
do j=0,n-2
c(:,j,:)=dble(j+1)*c(:,j+1,:)
end do
c(:,n-1,:)=0.d0
else if (m.eq.3) then
do j=0,n-2
c(:,:,j)=dble(j+1)*c(:,:,j+1)
end do
c(:,:,n-1)=0.d0
end if
end do
! derivative evaluated at zero
d(k,l)=c(0,0,0)
end do
end do
write(50,*)
write(50,*)
write(50,'("State, eigenvalue : ",I6,G18.10)') ist,evalsv(ist,ik0)
write(50,*)
write(50,'(" matrix of eigenvalue derivatives with respect to k :")')
do i=1,3
write(50,'(3G18.10)') (d(i,j),j=1,3)
end do
write(50,'(" trace : ",G18.10)') d(1,1)+d(2,2)+d(3,3)
! invert derivative matrix
call r3minv(d,em)
write(50,*)
write(50,'(" effective mass tensor (inverse of derivative matrix) :")')
do i=1,3
write(50,'(3G18.10)') (em(i,j),j=1,3)
end do
write(50,'(" trace : ",G18.10)') em(1,1)+em(2,2)+em(3,3)
! find the eigenvalues
call dsyev('N','U',3,em,3,w,work,9,info)
write(50,'(" eigenvalues :")')
write(50,'(3G18.10)') w
! end loop over states
end do
close(50)
write(*,*)
write(*,'("Info(effmass):")')
write(*,'(" Effective mass tensor for each state written to EFFMASS.OUT")')
write(*,'(" for k-point (lattice) ",3G18.10)') vklem
! write the effective mass eigenvalues of the last state to test file
call writetest(25,'effective mass',nv=3,tol=1.d-6,rva=w)
deallocate(ipiv,a,b,c)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genlmirep.f90 0000644 0000000 0000000 00000000132 13543334734 015130 x ustar 00 30 mtime=1569569244.976641723
30 atime=1569569241.205644132
30 ctime=1569569244.976641723
elk-6.3.2/src/genlmirep.f90 0000644 0025044 0025044 00000004346 13543334734 017206 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-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.
subroutine genlmirep(lmax,ld,elm,ulm)
use modmain
implicit none
! arguments
integer, intent(in) :: lmax
integer, intent(in) :: ld
real(8), intent(out) :: elm(ld,natmtot)
complex(8), intent(out) :: ulm(ld,ld,natmtot)
! local variables
integer isym,lspl,is,ia,ias
integer lmmax,i,j,l,lm,n,p
integer info,lwork
! allocatable arrays
real(8), allocatable :: rwork(:)
complex(8), allocatable :: ulat(:,:,:)
complex(8), allocatable :: a(:,:),b(:,:)
complex(8), allocatable :: h(:,:)
complex(8), allocatable :: work(:)
lmmax=(lmax+1)**2
allocate(rwork(3*lmmax))
allocate(ulat(lmmax,lmmax,nsymlat))
allocate(a(lmmax,lmmax),b(lmmax,lmmax))
allocate(h(lmmax,lmmax))
lwork=2*lmmax
allocate(work(lwork))
! construct (l,m) rotation matrix for each lattice symmetry
a(:,:)=0.d0
do i=1,lmmax
a(i,i)=1.d0
end do
do isym=1,nsymlat
call rotzflm(symlatc(:,:,isym),0,lmax,lmmax,lmmax,lmmax,a,ulat(:,:,isym))
end do
! set up pseudorandom symmetric matrix H
h(:,:)=0.d0
p=1
do l=0,lmax
n=2*l+1
lm=idxlm(l,-l)
do i=lm,lm+n-1
do j=i,lm+n-1
! Park and Miller linear congruential generator
p=mod(p*171,30269)
h(i,j)=mod(p,lmmax)
h(j,i)=h(i,j)
end do
end do
end do
! loop over species and atoms
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
! symmetrise H with site symmetries
b(:,:)=0.d0
do isym=1,nsymsite(ias)
! spatial rotation element in lattice point group
lspl=lsplsyms(isym,ias)
! apply lattice symmetry as U*H*conjg(U')
call zgemm('N','N',lmmax,lmmax,lmmax,zone,ulat(:,:,lspl),lmmax,h,lmmax, &
zzero,a,lmmax)
call zgemm('N','C',lmmax,lmmax,lmmax,zone,a,lmmax,ulat(:,:,lspl),lmmax, &
zone,b,lmmax)
end do
! block diagonalise symmetrised H
do l=0,lmax
n=2*l+1
lm=idxlm(l,-l)
call zheev('V','U',n,b(lm,lm),lmmax,elm(lm,ias),work,lwork,rwork,info)
end do
! the unitary matrix U is the transpose of the eigenvector array
do i=1,lmmax
do j=1,lmmax
ulm(i,j,ias)=b(j,i)
end do
end do
end do
end do
deallocate(rwork,ulat,a,b,h,work)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/ssfext.f90 0000644 0000000 0000000 00000000132 13543334734 014462 x ustar 00 30 mtime=1569569244.980641721
30 atime=1569569241.210644129
30 ctime=1569569244.980641721
elk-6.3.2/src/ssfext.f90 0000644 0025044 0025044 00000001233 13543334734 016530 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.
subroutine ssfext(iq,fext)
use modmain
implicit none
! arguments
integer, intent(in) :: iq
character(*), intent(out) :: fext
! local variables
integer i,j,m(3),n(3)
! external functions
integer gcd
external gcd
do i=1,3
if (ivq(i,iq).ne.0) then
j=gcd(ivq(i,iq),ngridq(i))
m(i)=ivq(i,iq)/j
n(i)=ngridq(i)/j
else
m(i)=0
n(i)=0
end if
end do
write(fext,'("_Q",2I2.2,"_",2I2.2,"_",2I2.2,".OUT")') m(1),n(1),m(2),n(2), &
m(3),n(3)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/sstask.f90 0000644 0000000 0000000 00000000132 13543334734 014456 x ustar 00 30 mtime=1569569244.984641718
30 atime=1569569241.215644125
30 ctime=1569569244.984641718
elk-6.3.2/src/sstask.f90 0000644 0025044 0025044 00000001675 13543334734 016536 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.
subroutine sstask(fnum,fext)
use modmain
use modmpi
implicit none
! arguments
integer, intent(in) :: fnum
character(*), intent(out) :: fext
! local variables
logical exist
! only master process should search for file
if (.not.mp_mpi) goto 10
do iqss=1,nqpt
! construct the spin-spiral file extension
call ssfext(iqss,fext)
! determine if the SS file exists
inquire(file='SS'//trim(fext),exist=exist)
if (.not.exist) then
open(fnum,file='SS'//trim(fext),form='FORMATTED')
return
end if
end do
iqss=0
write(*,*)
write(*,'("Info(sstask): nothing more to do")')
10 continue
! broadcast to all other processes
call mpi_bcast(iqss,1,mpi_integer,0,mpicom,ierror)
if (iqss.eq.0) then
fext='.OUT'
else
call ssfext(iqss,fext)
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/spiralsc.f90 0000644 0000000 0000000 00000000132 13543334734 014766 x ustar 00 30 mtime=1569569244.989641715
30 atime=1569569241.221644122
30 ctime=1569569244.989641715
elk-6.3.2/src/spiralsc.f90 0000644 0025044 0025044 00000004600 13543334734 017035 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.
subroutine spiralsc
!****** check MPI
use modmain
use modmpi
use modstore
implicit none
! local variables
integer nq,iq,jq
real(8) q
! store original parameters
natoms_(:)=natoms(:)
avec_(:,:)=avec(:,:)
atposl_(:,:,:)=atposl(:,:,:)
bfcmt0_(:,:,:)=bfcmt0(:,:,:)
mommtfix_(:,:,:)=mommtfix(:,:,:)
autokpt_=autokpt
ngridk_(:)=ngridk
! initialise universal variables
call init0
! initialise q-point dependent variables
call init2
! store original parameters
atposc_(:,:,:)=atposc(:,:,:)
10 continue
call sstask(80,filext)
! if nothing more to do then restore input parameters and return
if (iqss.eq.0) then
filext='.OUT'
natoms(:)=natoms_(:)
avec(:,:)=avec_(:,:)
atposl(:,:,:)=atposl_(:,:,:)
bfcmt0(:,:,:)=bfcmt0_(:,:,:)
mommtfix(:,:,:)=mommtfix_(:,:,:)
autokpt=autokpt_
ngridk(:)=ngridk_(:)
return
end if
! spiral dry run: just generate empty SS files
if (task.eq.352) goto 10
if (mp_mpi) then
write(*,'("Info(spiralsc): working on ",A)') 'SS'//trim(filext)
end if
! determine k-point grid size from radkpt
autokpt=.true.
! generate the spin-spiral supercell
call genscss
! initialise or read the charge density and potentials from file
if (task.eq.350) then
trdstate=.false.
else
trdstate=.true.
end if
! run the ground-state calculation
call gndstate
if (mp_mpi) then
write(80,'(I6,T20," : number of unit cells in supercell")') nscss
write(80,'(G18.10,T20," : total energy per unit cell")') engytot/dble(nscss)
write(80,*)
write(80,'("q-point in lattice and Cartesian coordinates :")')
write(80,'(3G18.10)') vql(:,iqss)
write(80,'(3G18.10)') vqc(:,iqss)
q=sqrt(vqc(1,iqss)**2+vqc(2,iqss)**2+vqc(3,iqss)**2)
write(80,'(G18.10,T20," : length of q-vector")') q
write(80,*)
nq=nint(dble(nqptnr)*wqpt(iqss))
write(80,'(I6,T20," : number of equivalent q-points")') nq
write(80,'("Equivalent q-points in lattice and Cartesian coordinates :")')
do iq=1,nqptnr
jq=iqmap(ivq(1,iq),ivq(2,iq),ivq(3,iq))
if (jq.eq.iqss) then
write(80,'(3G18.10)') vql(:,iq)
write(80,'(3G18.10)') vqc(:,iq)
write(80,*)
end if
end do
close(80)
! delete the eigenvector files
call delevec
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
goto 10
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genscss.f90 0000644 0000000 0000000 00000000132 13543334734 014613 x ustar 00 30 mtime=1569569244.993641712
30 atime=1569569241.226644118
30 ctime=1569569244.993641712
elk-6.3.2/src/genscss.f90 0000644 0025044 0025044 00000002767 13543334734 016676 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.
subroutine genscss
use modmain
use modstore
implicit none
! local variables
integer is,ia,na,i
real(8) vc(3),cs,sn,t1
! automatic arrays
real(8) vsc(3,nqptnr)
! find the smallest supercell which contains q-vector
call findscq(iqss,avec_,nscss,vsc)
! construct supercell atomic positions and magnetic fields
do is=1,nspecies
na=0
do ia=1,natoms_(is)
do i=1,nscss
na=na+1
if (na.gt.maxatoms) then
write(*,*)
write(*,'("Error(genscss): too many atoms in supercell : ",I8)') na
write(*,'(" for species ",I4)') is
write(*,'("Adjust maxatoms in modmain and recompile code")')
write(*,*)
stop
end if
vc(:)=vsc(:,i)+atposc_(:,ia,is)
! new atomic position in lattice coordinates
call r3mv(ainv,vc,atposl(:,na,is))
! rotate external B-field and fixed spin moment vector by angle q.r
t1=dot_product(vqc(:,iqss),vc(:))
cs=cos(t1); sn=sin(t1)
bfcmt0(1,na,is)=cs*bfcmt0_(1,ia,is)-sn*bfcmt0_(2,ia,is)
bfcmt0(2,na,is)=sn*bfcmt0_(1,ia,is)+cs*bfcmt0_(2,ia,is)
bfcmt0(3,na,is)=bfcmt0_(3,ia,is)
mommtfix(1,na,is)=cs*mommtfix_(1,ia,is)-sn*mommtfix_(2,ia,is)
mommtfix(2,na,is)=sn*mommtfix_(1,ia,is)+cs*mommtfix_(2,ia,is)
mommtfix(3,na,is)=mommtfix_(3,ia,is)
end do
end do
natoms(is)=na
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genfspecies.f90 0000644 0000000 0000000 00000000130 13543334734 015437 x ustar 00 29 mtime=1569569244.99764171
30 atime=1569569241.231644115
29 ctime=1569569244.99764171
elk-6.3.2/src/genfspecies.f90 0000644 0025044 0025044 00000006466 13543334734 017524 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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 genfspecies(zn,symb)
use modmain
use modmpi
implicit none
! arguments
real(8), intent(in) :: zn
character(*), intent(in) :: symb
! local variables
integer, parameter :: nit=4
integer nst,ist,jst
integer nmax,in,il,ik
integer nrm,nr,ir,it
integer n(maxstsp),l(maxstsp),k(maxstsp)
integer idx(maxstsp),iv(maxstsp)
real(8) rm,rmin,rmax
real(8) mass,t1,t2,t3
real(8) occ(maxstsp),eval(maxstsp),rv(maxstsp)
character(256) name
! allocatable arrays
real(8), allocatable :: r(:),rho(:),vr(:),rwf(:,:,:)
! external functions
real(8) massnucl
external massnucl
name='Fractional species'
! set up the initial occupancies
occ(:)=0.d0
t1=abs(zn)
nmax=1
ist=0
do in=1,maxstsp
do il=0,in-1
do ik=max(il,1),il+1
t2=dble(2*ik)
t2=min(t2,t1)
ist=ist+1
n(ist)=in
l(ist)=il
k(ist)=ik
occ(ist)=t2
if (t2.gt.epsocc) nmax=in
t1=t1-t2
if (ist.eq.maxstsp) then
if (t1.gt.epsocc) then
write(*,*)
write(*,'("Error(genfspecies): too many states for fractional &
&species ",A)') trim(symb)
write(*,*)
stop
else
goto 10
end if
end if
end do
end do
end do
10 continue
! minimum radius
rmin=2.d-6/sqrt(abs(zn))
! initial maximum radius
rmax=100.d0
! initial muffin-tin radius
rm=2.d0
! number of points to muffin-tin radius
nrm=100*(nmax+1)
! iterate the solution but not to self-consistency
do it=1,nit
! number of points to effective infinity
t1=log(rm/rmin)
t2=log(rmax/rmin)
t3=dble(nrm)*t2/t1
nr=int(t3)
allocate(r(nr),rho(nr),vr(nr),rwf(nr,2,maxstsp))
! generate logarithmic radial mesh
t2=t1/dble(nrm-1)
do ir=1,nr
r(ir)=rmin*exp(dble(ir-1)*t2)
end do
! solve the Kohn-Sham-Dirac equation for the atom
call atom(sol,.true.,zn,maxstsp,n,l,k,occ,3,0,nr,r,eval,rho,vr,rwf)
! check for spurious eigenvalues
do ist=2,maxstsp
if (eval(ist).lt.eval(1)) eval(ist)=1.d6
end do
! recompute the effective infinity
do ir=nr,1,-1
if (rho(ir).gt.1.d-20) then
rmax=1.75d0*r(ir)
exit
end if
end do
! estimate the muffin-tin radius
do ir=nr,1,-1
if (rho(ir).gt.2.d-2) then
rm=r(ir)
exit
end if
end do
if (rm.lt.1.d0) rm=1.d0
if (rm.gt.3.2d0) rm=3.2d0
! sort the eigenvalues
call sortidx(maxstsp,eval,idx)
! recompute the occupancies
occ(:)=0.d0
t1=abs(zn)
do ist=1,maxstsp
jst=idx(ist)
ik=k(jst)
t2=dble(2*ik)
t2=min(t2,t1)
occ(jst)=t2
t1=t1-t2
end do
deallocate(r,rho,vr,rwf)
end do
! rearrange the arrays
iv(:)=n(:)
n(:)=iv(idx(:))
iv(:)=l(:)
l(:)=iv(idx(:))
iv(:)=k(:)
k(:)=iv(idx(:))
rv(:)=occ(:)
occ(:)=rv(idx(:))
rv(:)=eval(:)
eval(:)=rv(idx(:))
! find the number of occupied states
nst=0
do ist=1,maxstsp
if (occ(ist).lt.epsocc) then
nst=ist
exit
end if
end do
! estimate the nuclear mass
mass=massnucl(zn)
! convert from 'atomic mass units' to atomic units
mass=mass*amu
! write the species file
call writespecies(symb,name,zn,mass,rmin,rm,rmax,nrm,nst,n,l,k,occ,eval)
if (mp_mpi) then
write(*,*)
write(*,'("Info(genfspecies): wrote fractional species file ",A,".in")') &
trim(symb)
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writespecies.f90 0000644 0000000 0000000 00000000132 13543334735 015655 x ustar 00 30 mtime=1569569245.002641707
30 atime=1569569241.237644111
30 ctime=1569569245.002641707
elk-6.3.2/src/writespecies.f90 0000644 0025044 0025044 00000005273 13543334735 017733 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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 writespecies(symb,name,zn,mass,rmin,rm,rmax,nrm,nst,n,l,k,occ,eval)
use modmain
use modmpi
implicit none
! arguments
character(*), intent(in) :: symb,name
real(8), intent(in) :: zn,mass
real(8), intent(in) :: rmin,rm,rmax
integer, intent(in) :: nrm,nst
integer, intent(in) :: n(nst),l(nst),k(nst)
real(8), intent(in) :: occ(nst)
real(8), intent(in) :: eval(nst)
! local variables
integer lmax,nlo
integer ist,jst,i
logical core(maxstsp),lorb(maxstsp)
! default APW band energy
real(8), parameter :: e0=0.15d0
! find which states belong to core
do ist=1,nst
if (eval(ist).lt.ecvcut) then
core(ist)=.true.
else
core(ist)=.false.
end if
end do
! check that the state for same n and l but different k is also core
do ist=1,nst
if (core(ist)) then
do jst=1,nst
if ((n(ist).eq.n(jst)).and.(l(ist).eq.l(jst))) core(jst)=.true.
end do
end if
end do
lmax=1
do ist=1,nst
if (.not.core(ist)) lmax=max(lmax,l(ist))
end do
! determine the local orbitals
nlo=lmax+1
lorb(:)=.false.
do ist=1,nst
if (.not.core(ist)) then
if ((l(ist).eq.0).or.(l(ist).lt.k(ist))) then
if ((eval(ist).lt.esccut).or.(l(ist).ge.2)) then
lorb(ist)=.true.
nlo=nlo+1
end if
end if
end if
end do
if (mp_mpi) then
open(55,file=trim(symb)//'.in',form='FORMATTED')
write(55,'(" ''",A,"''",T45,": spsymb")') trim(symb)
write(55,'(" ''",A,"''",T45,": spname")') trim(name)
write(55,'(G14.6,T45,": spzn")') zn
write(55,'(G18.10,T45,": spmass")') mass
write(55,'(G14.6,2F10.4,I6,T45,": rminsp, rmt, rmaxsp, nrmt")') rmin,rm, &
rmax,nrm
write(55,'(I4,T45,": nstsp")') nst
write(55,'(3I4,G14.6,L1,T45,": nsp, lsp, ksp, occsp, spcore")') n(1),l(1), &
k(1),occ(1),core(1)
do ist=2,nst
write(55,'(3I4,G14.6,L1)') n(ist),l(ist),k(ist),occ(ist),core(ist)
end do
write(55,'(I4,T45,": apword")') 1
write(55,'(F10.4,I4," ",L1,T45,": apwe0, apwdm, apwve")') e0,0,.false.
write(55,'(I4,T45,": nlx")') 0
write(55,'(I4,T45,": nlorb")') nlo
do i=0,lmax
write(55,'(2I4,T45,": lorbl, lorbord")') i,2
write(55,'(F10.4,I4," ",L1,T45,": lorbe0, lorbdm, lorbve")') e0,0,.false.
write(55,'(F10.4,I4," ",L1)') e0,1,.false.
end do
do ist=1,nst
if (lorb(ist)) then
write(55,'(2I4,T45,": lorbl, lorbord")') l(ist),2
write(55,'(F10.4,I4," ",L1,T45,": lorbe0, lorbdm, lorbve")') e0,0,.false.
write(55,'(F10.4,I4," ",L1)') eval(ist),0,.true.
end if
end do
close(55)
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/exxengy.f90 0000644 0000000 0000000 00000000132 13543334735 014636 x ustar 00 30 mtime=1569569245.006641704
30 atime=1569569241.242644108
30 ctime=1569569245.006641704
elk-6.3.2/src/exxengy.f90 0000644 0025044 0025044 00000005556 13543334735 016720 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.
subroutine exxengy
use modmain
use modmpi
use modomp
implicit none
! local variables
integer ik,ist,jst,is,ia
integer nrc,nrci,npc
integer m1,m2,nthd
complex(8) z1
! allocatable arrays
complex(8), allocatable :: wfcr1(:,:),wfcr2(:,:)
complex(8), allocatable :: zrhomt(:),zvclmt(:),zfmt(:)
! external functions
complex(8) zfmtinp
external zfmtinp
allocate(wfcr1(npcmtmax,2),wfcr2(npcmtmax,2))
allocate(zrhomt(npcmtmax),zvclmt(npcmtmax),zfmt(npcmtmax))
! zero the exchange energy
engyx=0.d0
!--------------------------------------------------!
! val-val-val and val-cr-val contributions !
!--------------------------------------------------!
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
!$OMP CRITICAL(exxengy_)
write(*,'("Info(exxengy): ",I6," of ",I6," k-points")') ik,nkpt
!$OMP END CRITICAL(exxengy_)
call exxengyk(ik)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! add energies from each process and redistribute
call mpi_allreduce(mpi_in_place,engyx,1,mpi_double_precision,mpi_sum,mpicom, &
ierror)
!-----------------------------------!
! core-core-core contribution !
!-----------------------------------!
! begin loops over atoms and species
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
do jst=1,nstsp(is)
if (spcore(jst,is)) then
do m2=-ksp(jst,is),ksp(jst,is)-1
! generate the core wavefunction in spherical coordinates (pass in m-1/2)
call wavefcr(.false.,lradstp,is,ia,jst,m2,npcmtmax,wfcr2)
do ist=1,nstsp(is)
if (spcore(ist,is)) then
do m1=-ksp(ist,is),ksp(ist,is)-1
call wavefcr(.false.,lradstp,is,ia,ist,m1,npcmtmax,wfcr1)
! calculate the complex overlap density
call zrho2(npc,wfcr1,wfcr1(:,2),wfcr2,wfcr2(:,2),zfmt)
call zfsht(nrc,nrci,zfmt,zrhomt)
! calculate the Coulomb potential
call zpotclmt(nrc,nrci,nrcmtmax,rlcmt(:,:,is),wprcmt(:,:,is), &
zrhomt,zvclmt)
z1=zfmtinp(nrc,nrci,wrcmt(:,is),zrhomt,zvclmt)
engyx=engyx-0.5d0*dble(z1)
end do
! end loop over ist
end if
end do
end do
! end loop over jst
end if
end do
! end loops over atoms and species
end do
end do
deallocate(wfcr1,wfcr2,zrhomt,zvclmt,zfmt)
return
contains
subroutine zrho2(n,x1,x2,y1,y2,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x1(n),x2(n),y1(n),y2(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x1(:))*y1(:)+conjg(x2(:))*y2(:)
return
end subroutine
end subroutine
elk-6.3.2/src/PaxHeaders.21352/exxengyk.f90 0000644 0000000 0000000 00000000132 13543334735 015011 x ustar 00 30 mtime=1569569245.011641701
30 atime=1569569241.247644105
30 ctime=1569569245.011641701
elk-6.3.2/src/exxengyk.f90 0000644 0025044 0025044 00000014664 13543334735 017073 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 exxengyk(ikp)
use modmain
implicit none
! arguments
integer, intent(in) :: ikp
! local variables
integer iq,ik,jk,i,m
integer nst1,nst2,ist,jst
integer is,ia,ias
integer nrc,nrci,npc
integer iv(3),ig
real(8) ex,vc(3)
complex(8) z1
! automatic arrays
integer idx(nstsv)
! allocatable arrays
real(8), allocatable :: vgqc(:,:),gqc(:),gclgq(:),jlgqrmt(:,:,:)
complex(8), allocatable :: apwalm(:,:,:,:),evecfv(:,:),evecsv(:,:)
complex(8), allocatable :: ylmgq(:,:),sfacgq(:,:)
complex(8), allocatable :: wfmt1(:,:,:,:),wfir1(:,:,:)
complex(8), allocatable :: wfmt2(:,:,:,:),wfir2(:,:,:)
complex(8), allocatable :: wfcr(:,:),zfmt(:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:)
complex(8), allocatable :: zvclmt(:,:),zvclir(:)
! external functions
complex(8) zfinp,zfmtinp
external zfinp,zfmtinp
! allocate local arrays
allocate(vgqc(3,ngvc),gqc(ngvc),gclgq(ngvc))
allocate(jlgqrmt(0:lnpsd,ngvc,nspecies))
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot))
allocate(evecfv(nmatmax,nstfv),evecsv(nstsv,nstsv))
allocate(ylmgq(lmmaxo,ngvc),sfacgq(ngvc,natmtot))
allocate(wfmt2(npcmtmax,natmtot,nspinor,nstsv))
allocate(wfir2(ngtc,nspinor,nstsv))
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
allocate(zvclmt(npcmtmax,natmtot),zvclir(ngtc))
! get the eigenvectors from file for input reduced k-point
call getevecfv(filext,ikp,vkl(:,ikp),vgkl(:,:,:,ikp),evecfv)
call getevecsv(filext,ikp,vkl(:,ikp),evecsv)
! find the matching coefficients
call match(ngk(1,ikp),vgkc(:,:,1,ikp),gkc(:,1,ikp),sfacgk(:,:,1,ikp),apwalm)
! count and index the occupied states
nst1=0
do ist=1,nstsv
if (evalsv(ist,ikp).lt.efermi) then
nst1=nst1+1
idx(nst1)=ist
end if
end do
! calculate the wavefunctions for occupied states of the input k-point
allocate(wfmt1(npcmtmax,natmtot,nspinor,nst1),wfir1(ngtc,nspinor,nst1))
call genwfsv(.false.,.false.,nst1,idx,ngdc,igfc,ngk(1,ikp),igkig(:,1,ikp), &
apwalm,evecfv,evecsv,wfmt1,ngtc,wfir1)
! zero the local exchange energy variable
ex=0.d0
! start loop over non-reduced k-point set
do ik=1,nkptnr
! equivalent reduced k-point
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
! determine the q-vector
iv(:)=ivk(:,ikp)-ivk(:,ik)
iv(:)=modulo(iv(:),ngridk(:))
! check if the q-point is in user-defined set
iv(:)=iv(:)*ngridq(:)
do i=1,3
if (modulo(iv(i),ngridk(i)).ne.0) goto 10
end do
iv(:)=iv(:)/ngridk(:)
iq=iqmap(iv(1),iv(2),iv(3))
vc(:)=vkc(:,ikp)-vkc(:,ik)
do ig=1,ngvc
! determine the G+q-vectors
vgqc(:,ig)=vgc(:,ig)+vc(:)
! G+q-vector length
gqc(ig)=sqrt(vgqc(1,ig)**2+vgqc(2,ig)**2+vgqc(3,ig)**2)
! spherical harmonics for G+q-vectors
call genylmv(lmaxo,vgqc(:,ig),ylmgq(:,ig))
end do
! structure factors for G+q
call gensfacgp(ngvc,vgqc,ngvc,sfacgq)
! generate the regularised Coulomb Green's function in G+q-space
call gengclgq(.true.,iq,ngvc,gqc,gclgq)
! compute the required spherical Bessel functions
call genjlgprmt(lnpsd,ngvc,gqc,ngvc,jlgqrmt)
! find the matching coefficients
call match(ngk(1,ik),vgkc(:,:,1,ik),gkc(:,1,ik),sfacgk(:,:,1,ik),apwalm)
! get the eigenvectors from file for non-reduced k-point
call getevecfv(filext,0,vkl(:,ik),vgkl(:,:,1,ik),evecfv)
call getevecsv(filext,0,vkl(:,ik),evecsv)
! count and index the occupied states
nst2=0
do jst=1,nstsv
if (evalsv(jst,jk).lt.efermi) then
nst2=nst2+1
idx(nst2)=jst
end if
end do
! calculate the wavefunctions for occupied states
call genwfsv(.false.,.false.,nst2,idx,ngdc,igfc,ngk(1,ik),igkig(:,1,ik), &
apwalm,evecfv,evecsv,wfmt2,ngtc,wfir2)
!--------------------------------------------!
! valence-valence-valence contribution !
!--------------------------------------------!
do jst=1,nst2
do ist=1,nst1
! calculate the complex overlap density
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,jst),wfir2(:,:,jst), &
wfmt1(:,:,:,ist),wfir1(:,:,ist),zrhomt,zrhoir)
! calculate the Coulomb potential
call genzvclmt(nrcmt,nrcmti,nrcmtmax,rlcmt,wprcmt,npcmtmax,zrhomt,zvclmt)
call zpotcoul(nrcmt,nrcmti,npcmt,npcmti,nrcmtmax,rlcmt,ngdc,igfc,ngvc, &
gqc,gclgq,ngvc,jlgqrmt,ylmgq,sfacgq,zrhoir,npcmtmax,zvclmt,zvclir)
z1=zfinp(zrhomt,zrhoir,zvclmt,zvclir)
ex=ex-0.5d0*occmax*wkpt(ikp)*wqptnr*dble(z1)
end do
end do
10 continue
! end loop over non-reduced k-point set
end do
deallocate(vgqc,gqc,gclgq,jlgqrmt)
deallocate(evecfv,evecsv)
deallocate(apwalm,ylmgq,sfacgq)
deallocate(wfmt2,wfir2)
!-----------------------------------------!
! valence-core-valence contribution !
!-----------------------------------------!
allocate(wfcr(npcmtmax,2),zfmt(npcmtmax))
! begin loops over atoms and species
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
do jst=1,nstsp(is)
if (spcore(jst,is)) then
do m=-ksp(jst,is),ksp(jst,is)-1
! generate the core wavefunction in spherical coordinates (pass in m-1/2)
call wavefcr(.false.,lradstp,is,ia,jst,m,npcmtmax,wfcr)
do ist=1,nst1
! calculate the complex overlap density in spherical harmonics
if (spinpol) then
call zrho2(npc,wfcr,wfcr(:,2),wfmt1(:,ias,1,ist), &
wfmt1(:,ias,2,ist),zfmt)
else
call zrho1(npc,wfcr,wfmt1(:,ias,1,ist),zfmt)
end if
call zfsht(nrc,nrci,zfmt,zrhomt(:,ias))
! calculate the Coulomb potential
call zpotclmt(nrc,nrci,nrcmtmax,rlcmt(:,:,is),wprcmt(:,:,is), &
zrhomt(:,ias),zvclmt(:,ias))
z1=zfmtinp(nrc,nrci,wrcmt(:,is),zrhomt(:,ias),zvclmt(:,ias))
ex=ex-occmax*wkpt(ikp)*dble(z1)
end do
! end loop over m
end do
! end loop over jst
end if
end do
! end loops over atoms and species
end do
end do
! add to global exchange energy
!$OMP CRITICAL(exxengyk_)
engyx=engyx+ex
!$OMP END CRITICAL(exxengyk_)
deallocate(wfmt1,wfir1,wfcr,zfmt)
deallocate(zrhomt,zrhoir,zvclmt,zvclir)
return
contains
subroutine zrho1(n,x,y,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x(n),y(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x(:))*y(:)
return
end subroutine
subroutine zrho2(n,x1,x2,y1,y2,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x1(n),x2(n),y1(n),y2(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x1(:))*y1(:)+conjg(x2(:))*y2(:)
return
end subroutine
end subroutine
elk-6.3.2/src/PaxHeaders.21352/xc_c_tb09.f90 0000644 0000000 0000000 00000000132 13543334735 014721 x ustar 00 30 mtime=1569569245.015641698
30 atime=1569569241.252644102
30 ctime=1569569245.015641698
elk-6.3.2/src/xc_c_tb09.f90 0000644 0025044 0025044 00000003351 13543334735 016772 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.
subroutine xc_c_tb09
use modmain
use libxcifc
implicit none
! local variables
integer is,ias,i
integer nr,nri,ir
real(8), parameter :: alpha=-0.012d0, beta=1.023d0
real(8) t1
! allocatable arrays
real(8), allocatable :: grfmt(:,:,:),grfir(:,:)
real(8), allocatable :: rfmt(:,:),rfir(:)
real(8), allocatable :: rfmt1(:),rfmt2(:,:)
! external functions
real(8) rfint
external rfint
! check that the Tran-Blaha functional is being used (A. Shyichuk)
if (xctype(2).ne.XC_MGGA_X_TB09) return
! if Tran-Blaha constant has been read in return
if (tc_tb09) return
! compute the gradient of the density
allocate(grfmt(npmtmax,natmtot,3),grfir(ngtot,3))
call gradrf(rhomt,rhoir,grfmt,grfir)
allocate(rfmt(npmtmax,natmtot),rfmt1(npmtmax),rfmt2(npmtmax,3))
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
! convert muffin-tin density to spherical coordinates
call rbsht(nr,nri,rhomt(:,ias),rfmt1)
! convert muffin-tin gradient to spherical coordinates
do i=1,3
call rbsht(nr,nri,grfmt(:,ias,i),rfmt2(:,i))
end do
! integrand in muffin-tin
do i=1,npmt(is)
t1=sqrt(rfmt2(i,1)**2+rfmt2(i,2)**2+rfmt2(i,3)**2)
rfmt1(i)=t1/rfmt1(i)
end do
! convert to spherical harmonics
call rfsht(nr,nri,rfmt1,rfmt(:,ias))
end do
deallocate(grfmt,rfmt1,rfmt2)
! integrand in interstitial
allocate(rfir(ngtot))
do ir=1,ngtot
t1=sqrt(grfir(ir,1)**2+grfir(ir,2)**2+grfir(ir,3)**2)
rfir(ir)=t1/rhoir(ir)
end do
! integrate over the unit cell
t1=rfint(rfmt,rfir)
! set the constant
c_tb09=alpha+beta*sqrt(abs(t1)/omega)
deallocate(grfir,rfmt,rfir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/elfplot.f90 0000644 0000000 0000000 00000000132 13543334735 014614 x ustar 00 30 mtime=1569569245.020641695
30 atime=1569569241.257644099
30 ctime=1569569245.020641695
elk-6.3.2/src/elfplot.f90 0000644 0025044 0025044 00000012510 13543334735 016662 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: elfplot
! !INTERFACE:
subroutine elfplot
! !USES:
use modmain
! !DESCRIPTION:
! Outputs the electron localisation function (ELF) for 1D, 2D or 3D plotting.
! The spin-averaged ELF is given by
! $$ f_{\rm ELF}({\bf r})=\frac{1}{1+[D({\bf r})/D^0({\bf r})]^2}, $$
! where
! $$ D({\bf r})=\frac{1}{2}\left(\tau({\bf r})-\frac{1}{4}
! \frac{[\nabla n({\bf r})]^2}{n({\bf r})}\right) $$
! and
! $$ \tau({\bf r})=\sum_{i=1}^N \left|\nabla\Psi_i({\bf r})
! \right|^2 $$
! is the spin-averaged kinetic energy density from the spinor wavefunctions.
! The function $D^0$ is the kinetic energy density for the homogeneous
! electron gas evaluated for $n({\bf r})$:
! $$ D^0({\bf r})=\frac{3}{5}(6\pi^2)^{2/3}\left(\frac{n({\bf r})}{2}
! \right)^{5/3}. $$
! The ELF is useful for the topological classification of bonding. See for
! example T. Burnus, M. A. L. Marques and E. K. U. Gross [Phys. Rev. A 71,
! 10501 (2005)].
!
! !REVISION HISTORY:
! Created September 2003 (JKD)
! Fixed bug found by F. Wagner (JKD)
!EOP
!BOC
implicit none
! local variables
integer ik,is,ias
integer nr,nri,ir
integer ig,ifg,i
real(8) r,t1,t2,t3
! allocatable arrays
real(8), allocatable :: gwf2mt(:,:),gwf2ir(:)
real(8), allocatable :: rfmt1(:),rfmt2(:),grfir(:)
real(8), allocatable :: grfmt1(:,:),grfmt2(:,:)
real(8), allocatable :: elfmt(:,:),elfir(:)
complex(8), allocatable :: evecfv(:,:),evecsv(:,:)
complex(8), allocatable :: zfft1(:),zfft2(:)
! initialise universal variables
call init0
call init1
! allocate local arrays
allocate(gwf2mt(npmtmax,natmtot),gwf2ir(ngtot))
allocate(rfmt1(npmtmax),rfmt2(npmtmax),grfir(ngtot))
allocate(grfmt1(npmtmax,3),grfmt2(npmtmax,3))
allocate(elfmt(npmtmax,natmtot),elfir(ngtot))
allocate(evecfv(nmatmax,nstfv),evecsv(nstsv,nstsv))
allocate(zfft1(ngtot),zfft2(ngtot))
! read density and potentials from file
call readstate
! generate the core wavefunctions and densities
call gencore
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! set the gradient squared to zero
gwf2mt(:,:)=0.d0
gwf2ir(:)=0.d0
do ik=1,nkpt
! get the eigenvectors and occupancies from file
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! add the valence wavefunction gradient squared
call gradwf2(ik,evecfv,evecsv,gwf2mt,gwf2ir)
end do
! add core wavefunction gradient squared
call gradwfcr2(gwf2mt)
!------------------------!
! muffin-tin ELF !
!------------------------!
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
! convert rho from spherical harmonics to spherical coordinates
call rbsht(nr,nri,rhomt(:,ias),rfmt1)
! compute the gradient of the density
call gradrfmt(nr,nri,rlmt(:,1,is),rlmt(:,-1,is),rhomt(:,ias),npmtmax,grfmt1)
! convert gradient to spherical coordinates
do i=1,3
call rbsht(nr,nri,grfmt1(:,i),grfmt2(:,i))
end do
do i=1,npmt(is)
r=abs(rfmt1(i))
! square of gradient of rho
t1=grfmt2(i,1)**2+grfmt2(i,2)**2+grfmt2(i,3)**2
! D for inhomogeneous density
t2=(1.d0/2.d0)*(gwf2mt(i,ias)-(1.d0/4.d0)*t1/r)
! D0 for uniform electron gas
t3=(3.d0/5.d0)*((6.d0*pi**2)**(2.d0/3.d0))*(r/2.d0)**(5.d0/3.d0)
! ELF function
rfmt2(i)=1.d0/(1.d0+(t2/t3)**2)
end do
! convert ELF from spherical coordinates to spherical harmonics
call rfsht(nr,nri,rfmt2,elfmt(:,ias))
end do
!--------------------------!
! interstitial ELF !
!--------------------------!
! Fourier transform density to G-space
zfft1(:)=rhoir(:)
call zfftifc(3,ngridg,-1,zfft1)
grfir(:)=0.d0
do i=1,3
zfft2(:)=0.d0
do ig=1,ngvec
ifg=igfft(ig)
! take the gradient
zfft2(ifg)=zi*vgc(i,ig)*zfft1(ifg)
end do
! Fourier transform gradient to real-space
call zfftifc(3,ngridg,1,zfft2)
do ir=1,ngtot
grfir(ir)=grfir(ir)+dble(zfft2(ir))**2
end do
end do
do ir=1,ngtot
r=abs(rhoir(ir))
! D for inhomogeneous density
t1=(1.d0/2.d0)*(gwf2ir(ir)-(1.d0/4.d0)*grfir(ir)/r)
! D0 for homogeneous electron gas
t2=(3.d0/5.d0)*((6.d0*pi**2)**(2.d0/3.d0))*(r/2.d0)**(5.d0/3.d0)
! ELF function
elfir(ir)=1.d0/(1.d0+(t1/t2)**2)
end do
! symmetrise the ELF
call symrf(nrmt,nrmti,npmt,npmtmax,elfmt,elfir)
! plot the ELF to file
select case(task)
case(51)
open(50,file='ELF1D.OUT',form='FORMATTED')
open(51,file='ELFLINES.OUT',form='FORMATTED')
call plot1d(50,51,1,elfmt,elfir)
close(50)
close(51)
write(*,*)
write(*,'("Info(elfplot):")')
write(*,'(" 1D ELF plot written to ELF1D.OUT")')
write(*,'(" vertex location lines written to ELFLINES.OUT")')
case(52)
open(50,file='ELF2D.OUT',form='FORMATTED')
call plot2d(.false.,50,1,elfmt,elfir)
close(50)
write(*,*)
write(*,'("Info(elfplot): 2D ELF plot written to ELF2D.OUT")')
case(53)
open(50,file='ELF3D.OUT',form='FORMATTED')
call plot3d(50,1,elfmt,elfir)
close(50)
write(*,*)
write(*,'("Info(elfplot): 3D ELF plot written to ELF3D.OUT")')
end select
deallocate(gwf2mt,gwf2ir,rfmt1,rfmt2,grfir)
deallocate(grfmt1,grfmt2,elfmt,elfir)
deallocate(evecfv,evecsv,zfft1,zfft2)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/potplot.f90 0000644 0000000 0000000 00000000132 13543334735 014650 x ustar 00 30 mtime=1569569245.024641692
30 atime=1569569241.262644095
30 ctime=1569569245.024641692
elk-6.3.2/src/potplot.f90 0000644 0025044 0025044 00000003735 13543334735 016727 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: potplot
! !INTERFACE:
subroutine potplot
! !USES:
use modmain
! !DESCRIPTION:
! Outputs the exchange, correlation and Coulomb potentials, read in from
! {\tt STATE.OUT}, for 1D, 2D or 3D plotting.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! initialise universal variables
call init0
! read the density and potentials from file
call readstate
! write the potential plots to file
select case(task)
case(41)
open(50,file='VCL1D.OUT',form='FORMATTED')
open(51,file='VLINES.OUT',form='FORMATTED')
call plot1d(50,51,1,vclmt,vclir)
close(50)
close(51)
open(50,file='VXC1D.OUT',form='FORMATTED')
open(51,file='VLINES.OUT',form='FORMATTED')
call plot1d(50,51,1,vxcmt,vxcir)
close(50)
close(51)
write(*,*)
write(*,'("Info(potplot):")')
write(*,'(" 1D Coulomb potential plot written to VCL1D.OUT")')
write(*,'(" 1D exchange-correlation potential plot written to VXC1D.OUT")')
write(*,'(" vertex location lines written to VLINES.OUT")')
case(42)
open(50,file='VCL2D.OUT',form='FORMATTED')
call plot2d(.false.,50,1,vclmt,vclir)
close(50)
open(50,file='VXC2D.OUT',form='FORMATTED')
call plot2d(.false.,50,1,vxcmt,vxcir)
close(50)
write(*,*)
write(*,'("Info(potplot):")')
write(*,'(" 2D Coulomb potential plot written to VCL2D.OUT")')
write(*,'(" 2D exchange-correlation potential plot written to VXC2D.OUT")')
case(43)
open(50,file='VCL3D.OUT',form='FORMATTED')
call plot3d(50,1,vclmt,vclir)
close(50)
open(50,file='VXC3D.OUT',form='FORMATTED')
call plot3d(50,1,vxcmt,vxcir)
close(50)
write(*,*)
write(*,'("Info(potplot):")')
write(*,'(" 3D Coulomb potential plot written to VCL3D.OUT")')
write(*,'(" 3D exchange-correlation potential plot written to VXC3D.OUT")')
end select
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/mae.f90 0000644 0000000 0000000 00000000132 13543334735 013711 x ustar 00 30 mtime=1569569245.029641689
30 atime=1569569241.267644092
30 ctime=1569569245.029641689
elk-6.3.2/src/mae.f90 0000644 0025044 0025044 00000010061 13543334735 015756 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 mae
use modmain
use modmpi
use modstore
implicit none
! local variables
integer i,j,im(2)
real(8) em(2),de
real(8) v1(3),v2(3),th
real(8) a(3,3),b(3,3)
! initialise global variables
call init0
! store original parameters
avec_(:,:)=avec(:,:)
spinpol_=spinpol
spinorb_=spinorb
cmagz_=cmagz
bfieldc0_(:)=bfieldc0(:)
reducebf_=reducebf
fsmtype_=fsmtype
vkloff_(:)=vkloff(:)
! enable spin-orbit coupling
spinorb=.true.
! enforce collinear magnetism in the z-direction
cmagz=.true.
! no fixed spin moment calculation: the crystal is rotated instead
fsmtype=0
! if task=28 then start from atomic densities; if task=29 read STATE.OUT
if (task.eq.28) then
trdstate=.false.
else
trdstate=.true.
end if
! zero k-point offset
vkloff(:)=0.d0
! start with large magnetic field
bfieldc0(1:2)=0.d0
bfieldc0(3)=-2.d0
! reduce the external magnetic field after each s.c. loop
reducebf=0.75d0
! generate the spin moment directions in (theta,phi) coordinates
call gentpmae
! open MAE_INFO.OUT
if (mp_mpi) then
open(71,file='MAE_INFO.OUT',form='FORMATTED')
write(71,*)
write(71,'("Scale factor of spin-orbit coupling term : ",G18.10)') socscf
end if
im(:)=1
em(1)=1.d8
em(2)=-1.d8
! loop over points on sphere
do i=1,npmae
if (mp_mpi) then
write(*,'("Info(mae): fixed spin moment direction ",I6," of ",I6)') i,npmae
end if
! rotate lattice vectors instead of moment (thanks to J. Glasbrenner,
! K. Bussmann and I. Mazin)
! first by -phi around the z-axis
v1(:)=0.d0
v1(3)=1.d0
th=-tpmae(2,i)
call axangrot(v1,th,a)
! then by -theta around the y-axis
v1(:)=0.d0
v1(2)=1.d0
th=-tpmae(1,i)
call axangrot(v1,th,b)
call r3mm(b,a,rotsht)
call r3mm(rotsht,avec_,avec)
! find the corresponding moment direction vector
call r3minv(rotsht,a)
v1(:)=0.d0
v1(3)=1.d0
call r3mv(a,v1,v2)
do j=1,3
if (abs(v2(j)).lt.epslat) v2(j)=0.d0
end do
! rotate the spherical cover used for the spherical harmonic transform
trotsht=.true.
! run the ground-state calculation
call gndstate
! subsequent calculations should read the previous density
trdstate=.true.
! make external magnetic field small
bfieldc0(3)=-0.01d0
if (mp_mpi) then
write(71,*)
write(71,'("Fixed spin moment direction point ",I6," of ",I6)') i,npmae
write(71,'("Spherical coordinates of direction : ",2G18.10)') tpmae(:,i)
write(71,'("Direction vector (Cartesian coordinates) : ",3G18.10)') v2
write(71,'("Calculated total moment magnitude : ",G18.10)') momtotm
write(71,'("Total energy : ",G22.12)') engytot
flush(71)
end if
! check for minimum and maximum total energy
if (engytot.lt.em(1)) then
em(1)=engytot
im(1)=i
end if
if (engytot.gt.em(2)) then
em(2)=engytot
im(2)=i
end if
! delete the eigenvector files
if (mp_mpi) call delevec
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
end do
! magnetic anisotropy energy
de=em(2)-em(1)
if (mp_mpi) then
write(71,*)
write(71,'("Minimum energy point : ",I6)') im(1)
write(71,'("Maximum energy point : ",I6)') im(2)
write(71,*)
write(71,'("Estimated magnetic anisotropy energy (MAE) : ",G18.10)') de
write(71,*)
write(71,'("MAE per unit volume : ",G18.10)') de/omega
close(71)
open(50,file='MAE.OUT',form='FORMATTED')
write(50,'(G18.10)') de
close(50)
open(50,file='MAEPUV.OUT',form='FORMATTED')
write(50,'(G18.10)') de/omega
close(50)
write(*,*)
write(*,'("Info(mae):")')
write(*,'(" Estimated magnetic anisotropy energy written to MAE.OUT")')
write(*,'(" MAE per unit volume written to MAEPUV.OUT")')
write(*,*)
write(*,'(" Number of fixed spin moment directions used : ",I6)') npmae
write(*,*)
write(*,'(" Additional information written to MAE_INFO.OUT")')
end if
! restore original input parameters
avec(:,:)=avec_(:,:)
spinpol=spinpol_
spinorb=spinorb_
cmagz=cmagz_
fsmtype=fsmtype_
bfieldc0(:)=bfieldc0_(:)
reducebf=reducebf_
vkloff(:)=vkloff_(:)
trotsht=.false.
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writestate.f90 0000644 0000000 0000000 00000000132 13543334735 015342 x ustar 00 30 mtime=1569569245.033641687
30 atime=1569569241.272644089
30 ctime=1569569245.033641687
elk-6.3.2/src/writestate.f90 0000644 0025044 0025044 00000006541 13543334735 017417 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: writestate
! !INTERFACE:
subroutine writestate
! !USES:
use modmain
use moddftu
! !DESCRIPTION:
! Writes the charge density, potentials and other relevant variables to the
! file {\tt STATE.OUT}. Note to developers: changes to the way the variables
! are written should be mirrored in {\tt readstate}.
!
! !REVISION HISTORY:
! Created May 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer idm,is,ias
! allocatable arrays
real(8), allocatable :: rfmt(:,:,:),rvfmt(:,:,:,:),rvfcmt(:,:,:,:)
open(40,file='STATE'//trim(filext),form='UNFORMATTED')
write(40) version
write(40) spinpol
write(40) nspecies
write(40) lmmaxo
write(40) nrmtmax
write(40) nrcmtmax
do is=1,nspecies
write(40) natoms(is)
write(40) nrmt(is)
write(40) rsp(1:nrmt(is),is)
write(40) nrcmt(is)
write(40) rcmt(1:nrcmt(is),is)
end do
write(40) ngridg
write(40) ngvec
write(40) ndmag
write(40) nspinor
write(40) fsmtype
write(40) ftmtype
write(40) dftu
write(40) lmmaxdm
write(40) xcgrad
! muffin-tin functions are unpacked to maintain backward compatibility
allocate(rfmt(lmmaxo,nrmtmax,natmtot))
if (spinpol) then
allocate(rvfmt(lmmaxo,nrmtmax,natmtot,ndmag))
allocate(rvfcmt(lmmaxo,nrcmtmax,natmtot,ndmag))
end if
! write the density
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),rhomt(:,ias),rfmt(:,:,ias))
end do
write(40) rfmt,rhoir
! write the Coulomb potential
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),vclmt(:,ias),rfmt(:,:,ias))
end do
write(40) rfmt,vclir
! write the exchange-correlation potential
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),vxcmt(:,ias),rfmt(:,:,ias))
end do
write(40) rfmt,vxcir
! write the Kohn-Sham effective potential
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),vsmt(:,ias),rfmt(:,:,ias))
end do
write(40) rfmt,vsir
if (spinpol) then
! write the magnetisation, exchange-correlation and effective magnetic fields
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),magmt(:,ias,idm), &
rvfmt(:,:,ias,idm))
end do
end do
write(40) rvfmt,magir
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),bxcmt(:,ias,idm), &
rvfmt(:,:,ias,idm))
end do
end do
write(40) rvfmt,bxcir
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrcmt(is),nrcmti(is),bsmt(:,ias,idm), &
rvfcmt(:,:,ias,idm))
end do
end do
write(40) rvfcmt,bsir
! write fixed spin moment magnetic fields
if (fsmtype.ne.0) then
write(40) bfsmc
write(40) bfsmcmt
end if
end if
! write the tau-DFT exchange-correlation potential
if (xcgrad.eq.4) then
do ias=1,natmtot
is=idxis(ias)
call rfmtpack(.false.,nrmt(is),nrmti(is),wxcmt(:,ias),rfmt(:,:,ias))
end do
write(40) rfmt,wxcir
end if
! write the potential matrix in each muffin-tin
if ((dftu.ne.0).or.(ftmtype.ne.0)) then
write(40) vmatmt
end if
! write the fixed tensor moment potential matrix
if (ftmtype.ne.0) then
write(40) vmftm
end if
close(40)
deallocate(rfmt)
if (spinpol) deallocate(rvfmt,rvfcmt)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/readstate.f90 0000644 0000000 0000000 00000000132 13543334735 015123 x ustar 00 30 mtime=1569569245.038641684
30 atime=1569569241.276644086
30 ctime=1569569245.038641684
elk-6.3.2/src/readstate.f90 0000644 0025044 0025044 00000022412 13543334735 017173 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: readstate
! !INTERFACE:
subroutine readstate
! !USES:
use modmain
use moddftu
! !DESCRIPTION:
! Reads in the charge density and other relevant variables from the file
! {\tt STATE.OUT}. Checks for version and parameter compatibility.
!
! !REVISION HISTORY:
! Created May 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
logical spinpol_
integer is,ia,ias,lmmax,lm,ir,jr
integer idm,jdm,mapidm(3),ios
integer i1,i2,i3,j1,j2,j3,n
integer version_(3)
integer nspecies_,natoms_,lmmaxo_
integer nrmt_(maxspecies),nrmtmax_
integer nrcmt_(maxspecies),nrcmtmax_
integer ngridg_(3),ngtot_,ngvec_
integer ndmag_,nspinor_,fsmtype_,ftmtype_
integer dftu_,lmmaxdm_,xcgrad_
real(8) t1
! allocatable arrays
integer, allocatable :: mapir(:)
real(8), allocatable :: rsp_(:,:),rcmt_(:,:)
real(8), allocatable :: rfmt_(:,:,:),rfir_(:)
real(8), allocatable :: rvfmt_(:,:,:,:),rvfir_(:,:)
real(8), allocatable :: rvfcmt_(:,:,:,:),rfmt(:,:)
real(8), allocatable :: bfsmcmt_(:,:),fi(:),fo(:)
complex(8), allocatable :: vsig_(:)
complex(8), allocatable :: vmatmt_(:,:,:,:,:),vmftm_(:,:,:,:,:)
open(40,file='STATE'//trim(filext),form='UNFORMATTED',status='OLD', &
iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readstate): error opening ",A)') 'STATE'//trim(filext)
write(*,*)
stop
end if
read(40) version_
if (version_(1).lt.2) then
write(*,*)
write(*,'("Error(readstate): unable to read STATE.OUT from versions earlier &
&than 2.0.0")')
write(*,*)
stop
end if
if (any(version(:).ne.version_(:))) then
write(*,*)
write(*,'("Warning(readstate): different versions")')
write(*,'(" current : ",I3.3,".",I3.3,".",I3.3)') version
write(*,'(" STATE.OUT : ",I3.3,".",I3.3,".",I3.3)') version_
end if
read(40) spinpol_
read(40) nspecies_
if (nspecies.ne.nspecies_) then
write(*,*)
write(*,'("Error(readstate): differing nspecies")')
write(*,'(" current : ",I4)') nspecies
write(*,'(" STATE.OUT : ",I4)') nspecies_
write(*,*)
stop
end if
read(40) lmmaxo_
lmmax=min(lmmaxo,lmmaxo_)
read(40) nrmtmax_
read(40) nrcmtmax_
allocate(rsp_(nrmtmax_,nspecies))
allocate(rcmt_(nrcmtmax_,nspecies))
do is=1,nspecies
read(40) natoms_
if (natoms(is).ne.natoms_) then
write(*,*)
write(*,'("Error(readstate): differing natoms for species ",I4)') is
write(*,'(" current : ",I4)') natoms(is)
write(*,'(" STATE.OUT : ",I4)') natoms_
write(*,*)
stop
end if
read(40) nrmt_(is)
read(40) rsp_(1:nrmt_(is),is)
read(40) nrcmt_(is)
read(40) rcmt_(1:nrcmt_(is),is)
end do
read(40) ngridg_
read(40) ngvec_
read(40) ndmag_
if ((spinpol_).and.(ndmag_.ne.1).and.(ndmag_.ne.3)) then
write(*,*)
write(*,'("Error(readstate): invalid ndmag in STATE.OUT : ",I8)') ndmag_
write(*,*)
stop
end if
read(40) nspinor_
read(40) fsmtype_
if ((version_(1).gt.2).or.(version_(2).ge.3)) then
read(40) ftmtype_
else
ftmtype_=0
end if
read(40) dftu_
read(40) lmmaxdm_
if ((version_(1).gt.5).or.((version_(1).eq.5).and.(version_(2).ge.1))) then
read(40) xcgrad_
else
xcgrad_=0
end if
ngtot_=ngridg_(1)*ngridg_(2)*ngridg_(3)
! map from old interstitial grid to new
allocate(mapir(ngtot))
ir=0
do i3=0,ngridg(3)-1
t1=dble(i3*ngridg_(3))/dble(ngridg(3))
j3=modulo(nint(t1),ngridg_(3))
do i2=0,ngridg(2)-1
t1=dble(i2*ngridg_(2))/dble(ngridg(2))
j2=modulo(nint(t1),ngridg_(2))
do i1=0,ngridg(1)-1
t1=dble(i1*ngridg_(1))/dble(ngridg(1))
j1=modulo(nint(t1),ngridg_(1))
ir=ir+1
jr=j3*ngridg_(2)*ngridg_(1)+j2*ngridg_(1)+j1+1
mapir(ir)=jr
end do
end do
end do
allocate(rfmt_(lmmaxo_,nrmtmax_,natmtot),rfir_(ngtot_))
allocate(rfmt(lmmaxo,nrmtmax))
n=max(nrmtmax,nrmtmax_)
allocate(fi(n),fo(n))
! read the muffin-tin density
read(40) rfmt_,rfir_
! regrid and pack the muffin-tin function
call rgfmt(rhomt)
! regrid the interstitial function
rhoir(:)=rfir_(mapir(:))
! read the Coulomb potential, regrid and pack
read(40) rfmt_,rfir_
call rgfmt(vclmt)
vclir(:)=rfir_(mapir(:))
! read the exchange-correlation potential, regrid and pack
read(40) rfmt_,rfir_
call rgfmt(vxcmt)
vxcir(:)=rfir_(mapir(:))
! read the Kohn-Sham effective potential, regrid and pack
if ((version_(1).gt.2).or.(version_(2).ge.2)) then
read(40) rfmt_,rfir_
else
allocate(vsig_(ngvec_))
read(40) rfmt_,rfir_,vsig_
deallocate(vsig_)
end if
call rgfmt(vsmt)
vsir(:)=rfir_(mapir(:))
! read the magnetisation, exchange-correlation and effective magnetic fields
if (spinpol_) then
! component map for spin-polarised case
mapidm(:)=0
if (ndmag.eq.ndmag_) then
do idm=1,ndmag
mapidm(idm)=idm
end do
else
mapidm(ndmag)=ndmag_
end if
allocate(rvfmt_(lmmaxo_,nrmtmax_,natmtot,ndmag_))
allocate(rvfir_(ngtot_,ndmag_))
allocate(rvfcmt_(lmmaxo_,nrcmtmax_,natmtot,ndmag_))
read(40) rvfmt_,rvfir_
call rgvfmt(magmt)
call rgvir(magir)
read(40) rvfmt_,rvfir_
call rgvfmt(bxcmt)
call rgvir(bxcir)
read(40) rvfcmt_,rvfir_
call rgvfcmt(bsmt)
call rgvir(bsir)
deallocate(rvfmt_,rvfir_,rvfcmt_)
! read fixed spin moment effective fields
if (fsmtype_.ne.0) then
allocate(bfsmcmt_(3,natmtot))
read(40) bfsmc
read(40) bfsmcmt_
if (fsmtype.ne.0) bfsmcmt(:,:)=bfsmcmt_(:,:)
! make sure that the constraining fields are perpendicular to the fixed moments
! for fixed direction calculations (Y. Kvashnin and LN)
if (fsmtype.lt.0) then
if (ncmag) then
call r3vo(momfix,bfsmc)
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
call r3vo(mommtfix(:,ia,is),bfsmcmt(:,ias))
end do
end do
else
bfsmc(:)=0.d0
bfsmcmt(:,:)=0.d0
end if
end if
deallocate(bfsmcmt_)
end if
end if
if (xcgrad.eq.4) then
if (xcgrad_.eq.4) then
read(40) rfmt_,rfir_
call rgfmt(wxcmt)
wxcir(:)=rfir_(mapir(:))
else
wxcmt(:,:)=0.d0
wxcir(:)=0.d0
end if
call genws
end if
deallocate(rfmt_,rfir_,rfmt,fi,fo)
! read DFT+U potential matrix in each muffin-tin
if (((dftu.ne.0).and.(dftu_.ne.0)).or. &
((ftmtype.ne.0).and.(ftmtype_.ne.0))) then
allocate(vmatmt_(lmmaxdm_,nspinor_,lmmaxdm_,nspinor_,natmtot))
read(40) vmatmt_
lmmax=min(lmmaxdm,lmmaxdm_)
vmatmt(:,:,:,:,:)=0.d0
if (nspinor.eq.nspinor_) then
vmatmt(1:lmmax,:,1:lmmax,:,:)=vmatmt_(1:lmmax,:,1:lmmax,:,:)
else if ((nspinor.eq.1).and.(nspinor_.eq.2)) then
vmatmt(1:lmmax,1,1:lmmax,1,:)=0.5d0*(vmatmt_(1:lmmax,1,1:lmmax,1,:) &
+vmatmt_(1:lmmax,2,1:lmmax,2,:))
else
vmatmt(1:lmmax,1,1:lmmax,1,:)=vmatmt_(1:lmmax,1,1:lmmax,1,:)
vmatmt(1:lmmax,2,1:lmmax,2,:)=vmatmt_(1:lmmax,1,1:lmmax,1,:)
end if
deallocate(vmatmt_)
end if
! read fixed tensor moment potential matrix elements
if ((ftmtype.ne.0).and.(ftmtype_.ne.0)) then
allocate(vmftm_(lmmaxdm_,nspinor_,lmmaxdm_,nspinor_,natmtot))
read(40) vmftm_
lmmax=min(lmmaxdm,lmmaxdm_)
vmftm_(:,:,:,:,:)=0.d0
if (nspinor.eq.nspinor_) then
vmftm(1:lmmax,:,1:lmmax,:,:)=vmftm_(1:lmmax,:,1:lmmax,:,:)
else if ((nspinor.eq.1).and.(nspinor_.eq.2)) then
vmftm(1:lmmax,1,1:lmmax,1,:)=0.5d0*(vmftm_(1:lmmax,1,1:lmmax,1,:) &
+vmftm_(1:lmmax,2,1:lmmax,2,:))
else
vmftm(1:lmmax,1,1:lmmax,1,:)=vmftm_(1:lmmax,1,1:lmmax,1,:)
vmftm(1:lmmax,2,1:lmmax,2,:)=vmftm_(1:lmmax,1,1:lmmax,1,:)
end if
deallocate(vmftm_)
end if
close(40)
return
contains
subroutine rgfmt(rfmtp)
implicit none
! arguments
real(8), intent(out) :: rfmtp(npmtmax,natmtot)
do ias=1,natmtot
is=idxis(ias)
! regrid the muffin-tin function
do lm=1,lmmax
fi(1:nrmt_(is))=rfmt_(lm,1:nrmt_(is),ias)
call rfinterp(nrmt_(is),rsp_(:,is),fi,nrmt(is),rsp(:,is),fo)
rfmt(lm,1:nrmt(is))=fo(1:nrmt(is))
end do
rfmt(lmmax+1:lmmaxo,1:nrmt(is))=0.d0
! pack the muffin-tin function
call rfmtpack(.true.,nrmt(is),nrmti(is),rfmt,rfmtp(:,ias))
end do
return
end subroutine
subroutine rgvfmt(rvfmt)
implicit none
! arguments
real(8), intent(out) :: rvfmt(npmtmax,natmtot,ndmag)
do idm=1,ndmag
jdm=mapidm(idm)
if (jdm.eq.0) then
rvfmt(:,:,idm)=0.d0
cycle
end if
do ias=1,natmtot
is=idxis(ias)
do lm=1,lmmax
fi(1:nrmt_(is))=rvfmt_(lm,1:nrmt_(is),ias,jdm)
call rfinterp(nrmt_(is),rsp_(:,is),fi,nrmt(is),rsp(:,is),fo)
rfmt(lm,1:nrmt(is))=fo(1:nrmt(is))
end do
rfmt(lmmax+1:lmmaxo,1:nrmt(is))=0.d0
call rfmtpack(.true.,nrmt(is),nrmti(is),rfmt,rvfmt(:,ias,idm))
end do
end do
return
end subroutine
subroutine rgvfcmt(rvfcmt)
implicit none
! arguments
real(8), intent(out) :: rvfcmt(npcmtmax,natmtot,ndmag)
do idm=1,ndmag
jdm=mapidm(idm)
if (jdm.eq.0) then
rvfcmt(:,:,idm)=0.d0
cycle
end if
do ias=1,natmtot
is=idxis(ias)
do lm=1,lmmax
fi(1:nrcmt_(is))=rvfcmt_(lm,1:nrcmt_(is),ias,jdm)
call rfinterp(nrcmt_(is),rcmt_(:,is),fi,nrcmt(is),rcmt(:,is),fo)
rfmt(lm,1:nrcmt(is))=fo(1:nrcmt(is))
end do
rfmt(lmmax+1:lmmaxo,1:nrcmt(is))=0.d0
call rfmtpack(.true.,nrcmt(is),nrcmti(is),rfmt,rvfcmt(:,ias,idm))
end do
end do
return
end subroutine
subroutine rgvir(rvfir)
implicit none
! arguments
real(8), intent(out) :: rvfir(ngtot,ndmag)
do idm=1,ndmag
jdm=mapidm(idm)
if (jdm.eq.0) then
rvfir(:,idm)=0.d0
cycle
end if
rvfir(:,idm)=rvfir_(mapir(:),jdm)
end do
return
end subroutine
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rotaxang.f90 0000644 0000000 0000000 00000000132 13543334735 014772 x ustar 00 30 mtime=1569569245.042641681
30 atime=1569569241.281644083
30 ctime=1569569245.042641681
elk-6.3.2/src/rotaxang.f90 0000644 0025044 0025044 00000006272 13543334735 017050 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 Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: rotaxang
! !INTERFACE:
subroutine rotaxang(eps,rot,det,v,th)
! !INPUT/OUTPUT PARAMETERS:
! eps : zero vector tolerance (in,real)
! rot : rotation matrix (in,real(3,3))
! det : matrix determinant (out,real)
! v : normalised axis vector (out,real(3))
! th : rotation angle (out,real)
! !DESCRIPTION:
! Given a rotation matrix
! $$ R(\hat{\bf v},\theta)=
! \left(\begin{matrix}
! \cos\theta+x^2(1-\cos\theta) &
! xy(1-\cos\theta)+z\sin\theta &
! xz(1-\cos\theta)-y\sin\theta \\
! xy(1-\cos\theta)-z\sin\theta &
! \cos\theta+y^2(1-\cos\theta) &
! yz(1-\cos\theta)+x\sin\theta \\
! xz(1-\cos\theta)+y\sin\theta &
! yz(1-\cos\theta)-x\sin\theta &
! \cos\theta+z^2(1-\cos\theta)
! \end{matrix}\right), $$
! this routine determines the axis of rotation $\hat{\bf v}$ and the angle of
! rotation $\theta$. If $R$ corresponds to an improper rotation then only the
! proper part is used and {\tt det} is set to $-1$. The rotation convention
! follows the `right-hand rule'.
!
! !REVISION HISTORY:
! Created December 2006 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: eps
real(8), intent(in) :: rot(3,3)
real(8), intent(out) :: det
real(8), intent(out) :: v(3),th
! local variables
real(8), parameter :: pi=3.1415926535897932385d0
real(8) rotp(3,3),t1,t2
! find the determinant
det=rot(1,2)*rot(2,3)*rot(3,1)-rot(1,3)*rot(2,2)*rot(3,1) &
+rot(1,3)*rot(2,1)*rot(3,2)-rot(1,1)*rot(2,3)*rot(3,2) &
+rot(1,1)*rot(2,2)*rot(3,3)-rot(1,2)*rot(2,1)*rot(3,3)
if (abs(det-1.d0).lt.eps) then
det=1.d0
else if (abs(det+1.d0).lt.eps) then
det=-1.d0
else
goto 10
end if
! proper rotation matrix
rotp(:,:)=det*rot(:,:)
v(1)=(rotp(2,3)-rotp(3,2))/2.d0
v(2)=(rotp(3,1)-rotp(1,3))/2.d0
v(3)=(rotp(1,2)-rotp(2,1))/2.d0
t1=sqrt(v(1)**2+v(2)**2+v(3)**2)
t2=(rotp(1,1)+rotp(2,2)+rotp(3,3)-1.d0)/2.d0
if (abs(abs(t2)-1.d0).gt.eps) then
! theta not equal to 0 or pi
th=-atan2(t1,t2)
v(:)=v(:)/t1
else
! special case of sin(th)=0
if (t2.gt.0.d0) then
! zero angle: axis arbitrary
th=0.d0
v(:)=1.d0/sqrt(3.d0)
else
! rotation by pi
th=pi
if ((rotp(1,1).ge.rotp(2,2)).and.(rotp(1,1).ge.rotp(3,3))) then
if (rotp(1,1).lt.(-1.d0+eps)) goto 10
v(1)=sqrt(abs(rotp(1,1)+1.d0)/2.d0)
v(2)=(rotp(2,1)+rotp(1,2))/(4.d0*v(1))
v(3)=(rotp(3,1)+rotp(1,3))/(4.d0*v(1))
else if ((rotp(2,2).ge.rotp(1,1)).and.(rotp(2,2).ge.rotp(3,3))) then
if (rotp(2,2).lt.(-1.d0+eps)) goto 10
v(2)=sqrt(abs(rotp(2,2)+1.d0)/2.d0)
v(3)=(rotp(3,2)+rotp(2,3))/(4.d0*v(2))
v(1)=(rotp(1,2)+rotp(2,1))/(4.d0*v(2))
else
if (rotp(3,3).lt.(-1.d0+eps)) goto 10
v(3)=sqrt(abs(rotp(3,3)+1.d0)/2.d0)
v(1)=(rotp(1,3)+rotp(3,1))/(4.d0*v(3))
v(2)=(rotp(2,3)+rotp(3,2))/(4.d0*v(3))
end if
end if
end if
return
10 continue
write(*,*)
write(*,'("Error(rotaxang): invalid rotation matrix:")')
write(*,'(3G18.10)') rot(1,:)
write(*,'(3G18.10)') rot(2,:)
write(*,'(3G18.10)') rot(3,:)
write(*,*)
stop
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/axangrot.f90 0000644 0000000 0000000 00000000132 13543334735 014772 x ustar 00 30 mtime=1569569245.046641678
30 atime=1569569241.285644081
30 ctime=1569569245.046641678
elk-6.3.2/src/axangrot.f90 0000644 0025044 0025044 00000002526 13543334735 017046 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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.
!BOP
! !ROUTINE: axangrot
! !INTERFACE:
subroutine axangrot(v,th,rot)
! !INPUT/OUTPUT PARAMETERS:
! v : axis vector (in,real)
! th : rotation angle (in,real)
! rot : rotation matrix (out,real(3,3))
! !DESCRIPTION:
! Determines the $3\times 3$ rotation matrix of a rotation specified by an
! axis-angle pair following the `right-hand rule'. The axis vector need not be
! normalised. See {\tt rotaxang} for details.
!
! !REVISION HISTORY:
! Created February 2014 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: v(3),th
real(8), intent(out) :: rot(3,3)
! local variables
real(8) x,y,z,x2,y2,z2
real(8) xy,xz,yz,cs,sn,t1
x=v(1); y=v(2); z=v(3)
t1=sqrt(x**2+y**2+z**2)
! if the axis has zero length then assume the identity
if (t1.lt.1.d-14) then
rot(:,:)=0.d0
rot(1,1)=1.d0
rot(2,2)=1.d0
rot(3,3)=1.d0
return
end if
t1=1.d0/t1
x=x*t1; y=y*t1; z=z*t1
x2=x**2; y2=y**2; z2=z**2
xy=x*y; xz=x*z; yz=y*z
cs=cos(th); sn=sin(th)
t1=1.d0-cs
rot(1,1)=cs+x2*t1
rot(2,1)=xy*t1+z*sn
rot(3,1)=xz*t1-y*sn
rot(1,2)=xy*t1-z*sn
rot(2,2)=cs+y2*t1
rot(3,2)=yz*t1+x*sn
rot(1,3)=xz*t1+y*sn
rot(2,3)=yz*t1-x*sn
rot(3,3)=cs+z2*t1
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/dmatls.f90 0000644 0000000 0000000 00000000132 13543334735 014433 x ustar 00 30 mtime=1569569245.051641675
30 atime=1569569241.290644077
30 ctime=1569569245.051641675
elk-6.3.2/src/dmatls.f90 0000644 0025044 0025044 00000001630 13543334735 016502 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 dmatls(dmat,xl,xs)
use modmain
implicit none
! arguments
complex(8), intent(in) :: dmat(lmmaxo,nspinor,lmmaxo,nspinor)
real(8), intent(out) :: xl(3),xs(3)
! local variables
integer ispn,lm
! automatic arrays
complex(8) zlflm(lmmaxo,3)
! compute tr(LD)
xl(:)=0.d0
do ispn=1,nspinor
do lm=1,lmmaxo
call lopzflm(lmaxo,dmat(:,ispn,lm,ispn),lmmaxo,zlflm)
xl(:)=xl(:)+dble(zlflm(lm,:))
end do
end do
! compute tr(sigma D)
xs(:)=0.d0
if (spinpol) then
do lm=1,lmmaxo
xs(1)=xs(1)+dble(dmat(lm,2,lm,1)+dmat(lm,1,lm,2))
xs(2)=xs(2)+dble(-zi*dmat(lm,2,lm,1)+zi*dmat(lm,1,lm,2))
xs(3)=xs(3)+dble(dmat(lm,1,lm,1)-dmat(lm,2,lm,2))
end do
! S = 1/2 sigma
xs(:)=0.5d0*xs(:)
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gendmat.f90 0000644 0000000 0000000 00000000132 13543334735 014566 x ustar 00 30 mtime=1569569245.055641673
30 atime=1569569241.294644075
30 ctime=1569569245.055641673
elk-6.3.2/src/gendmat.f90 0000644 0025044 0025044 00000004336 13543334735 016643 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 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 gendmat(tspndg,tlmdg,lmin,lmax,ld,dmat)
use modmain
use modmpi
use modomp
implicit none
! arguments
logical, intent(in) :: tspndg,tlmdg
integer, intent(in) :: lmin,lmax,ld
complex(8), intent(out) :: dmat(ld,nspinor,ld,nspinor,natmtot)
! local variables
integer ik,ispn,ist
integer ias,n,nthd
real(8) wo
! allocatable arrays
complex(8), allocatable :: apwalm(:,:,:,:,:),evecfv(:,:,:),evecsv(:,:)
complex(8), allocatable :: dmatk(:,:,:,:,:)
! zero the density matrix
dmat(:,:,:,:,:)=0.d0
! begin parallel loop over k-points
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(apwalm,evecfv,evecsv,dmatk) &
!$OMP PRIVATE(ispn,ias,ist,wo) &
!$OMP NUM_THREADS(nthd)
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
allocate(evecfv(nmatmax,nstfv,nspnfv),evecsv(nstsv,nstsv))
allocate(dmatk(ld,nspinor,ld,nspinor,nstsv))
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
! find the matching coefficients
do ispn=1,nspnfv
call match(ngk(ispn,ik),vgkc(:,:,ispn,ik),gkc(:,ispn,ik), &
sfacgk(:,:,ispn,ik),apwalm(:,:,:,:,ispn))
end do
! get the eigenvectors from file
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! begin loop over atoms and species
do ias=1,natmtot
call gendmatk(tspndg,tlmdg,lmin,lmax,ias,ngk(:,ik),apwalm,evecfv,evecsv, &
ld,dmatk)
do ist=1,nstsv
wo=wkpt(ik)*occsv(ist,ik)
if (wo.lt.epsocc) cycle
!$OMP CRITICAL(gendmat_)
dmat(:,:,:,:,ias)=dmat(:,:,:,:,ias)+wo*dmatk(:,:,:,:,ist)
!$OMP END CRITICAL(gendmat_)
end do
end do
end do
!$OMP END DO
deallocate(apwalm,evecfv,evecsv,dmatk)
!$OMP END PARALLEL
call freethd(nthd)
! add density matrices from each process and redistribute
if (np_mpi.gt.1) then
n=((ld*nspinor)**2)*natmtot
call mpi_allreduce(mpi_in_place,dmat,n,mpi_double_complex,mpi_sum,mpicom, &
ierror)
end if
! symmetrise the density matrix
call symdmat(lmax,ld,dmat)
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/numlist.f90 0000644 0000000 0000000 00000000130 13543334735 014640 x ustar 00 29 mtime=1569569245.05964167
30 atime=1569569241.300644071
29 ctime=1569569245.05964167
elk-6.3.2/src/numlist.f90 0000644 0025044 0025044 00000001574 13543334735 016720 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2015 Manh Duc Le, 2017-18 Arsenii Gerasimov, Yaroslav Kvashnin,
! Lars Nordstrom and J. K. Dewhurst. This file is distributed under the terms of
! the GNU General Public License. See the file COPYING for license details.
subroutine numlist(str,n,list)
implicit none
! arguments
character(256), intent(in) :: str
integer, intent(inout) :: n
integer, intent(out) :: list(n)
! local variables
integer i0,i1,i,j,m,ios
! automatic arrays
integer l(n)
i=0
i0=1
do
m=index(str(i0:),'-')
if (m.eq.0) then
i1=256
else
i1=i0+m-2
end if
l(:)=0
read(str(i0:i1),*,iostat=ios) l
if (i.gt.0) then
do j=list(i)+1,l(1)-1
if (i.eq.n) goto 10
i=i+1
list(i)=j
end do
end if
do j=1,n
if (l(j).eq.0) exit
if (i.eq.n) goto 10
i=i+1
list(i)=l(j)
end do
if (m.eq.0) exit
i0=i0+m
end do
10 continue
n=i
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/sbesseldm.f90 0000644 0000000 0000000 00000000132 13543334735 015130 x ustar 00 30 mtime=1569569245.064641667
30 atime=1569569241.304644068
30 ctime=1569569245.064641667
elk-6.3.2/src/sbesseldm.f90 0000644 0025044 0025044 00000006106 13543334735 017202 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: sbesseldm
! !INTERFACE:
subroutine sbesseldm(m,lmax,x,djl)
! !INPUT/OUTPUT PARAMETERS:
! m : order of derivatve (in,integer)
! lmax : maximum order of Bessel function (in,integer)
! x : real argument (in,real)
! djl : array of returned values (out,real(0:lmax))
! !DESCRIPTION:
! Computes the $m$th derivative of the spherical Bessel function of the first
! kind, $j_l(x)$, for argument $x$ and $l=0,1,\ldots,l_{\rm max}$. For
! $x\ge 1$ this is done by repeatedly using the relations
! \begin{align*}
! \frac{d}{dx}j_l(x)&=\frac{l}{x}j_l(x)-j_{l+1}(x) \\
! j_{l+1}(x)&=\frac{2l+1}{x}j_l(x)-j_{l-1}(x).
! \end{align*}
! While for $x<1$ the series expansion of the Bessel function is used
! $$ \frac{d^m}{dx^m}j_l(x)=\sum_{i=0}^{\infty}
! \frac{(2i+l)!}{(-2)^ii!(2i+l-m)!(2i+2l+1)!!}x^{2i+l-m}. $$
! This procedure is numerically stable and accurate to near machine precision
! for $l\le 30$ and $m\le 6$.
!
! !REVISION HISTORY:
! Created March 2003 (JKD)
! Modified to return an array of values, October 2004 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: m,lmax
real(8), intent(in) :: x
real(8), intent(out) :: djl(0:lmax)
! local variables
integer, parameter :: maxm=6,maxns=20
integer i,j,l,i0
real(8) t1,sum,x2
integer a(0:maxm+1),a1(0:maxm+1)
integer b(0:maxm+1),b1(0:maxm+1)
! automatic arrays
real(8) jl(0:lmax+1)
! external functions
real(8) factnm,factr
external factnm,factr
if ((m.lt.0).or.(m.gt.maxm)) then
write(*,*)
write(*,'("Error(sbesseldm): m out of range : ",I8)') m
write(*,*)
stop
end if
if ((lmax.lt.0).or.(lmax.gt.30)) then
write(*,*)
write(*,'("Error(sbesseldm): lmax out of range : ",I8)') lmax
write(*,*)
stop
end if
if ((x.lt.0.d0).or.(x.gt.1.d5)) then
write(*,*)
write(*,'("Error(sbesseldm): x out of range : ",G18.10)') x
write(*,*)
stop
end if
if (m.eq.0) then
call sbessel(lmax,x,djl)
return
end if
if (x.gt.1.d0) then
call sbessel(lmax+1,x,jl)
do l=0,lmax
a(1:m+1)=0
a(0)=1
a1(0:m+1)=0
do i=1,m
b(0)=0
b1(0)=0
do j=0,i
b(j+1)=a(j)*(l-j)
b1(j+1)=-a1(j)*(j+l+2)
end do
do j=0,i
b1(j)=b1(j)-a(j)
b(j)=b(j)+a1(j)
end do
a(0:i+1)=b(0:i+1)
a1(0:i+1)=b1(0:i+1)
end do
t1=1.d0
sum=dble(a(0))*jl(l)+dble(a1(0))*jl(l+1)
do i=1,m+1
t1=t1*x
sum=sum+(dble(a(i))*jl(l)+dble(a1(i))*jl(l+1))/t1
end do
djl(l)=sum
end do
else
x2=x**2
do l=0,lmax
i0=max((m-l+1)/2,0)
j=2*i0+l-m
if (j.eq.0) then
t1=1.d0
else
t1=x**j
end if
t1=factr(j+m,j)*t1/(factnm(i0,1)*factnm(j+l+m+1,2)*dble((-2)**i0))
sum=t1
do i=i0+1,maxns
j=2*i+l
t1=-t1*dble((j-1)*j)*x2/dble((j-l)*(j-m-1)*(j-m)*(j+l+1))
if (abs(t1).le.1.d-40) goto 10
sum=sum+t1
end do
10 continue
djl(l)=sum
end do
end if
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/genvchi0.f90 0000644 0000000 0000000 00000000132 13543334735 014652 x ustar 00 30 mtime=1569569245.068641664
30 atime=1569569241.309644065
30 ctime=1569569245.068641664
elk-6.3.2/src/genvchi0.f90 0000644 0025044 0025044 00000012370 13543334735 016724 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine genvchi0(t3hw,ik,lock,scsr,vqpl,gclgq,jlgqr,ylmgq,sfacgq,nm,vchi0)
use modmain
use modomp
implicit none
! local variables
logical, intent(in) :: t3hw
integer, intent(in) :: ik
integer(8), intent(in) :: lock(nwrf)
real(8), intent(in) :: scsr,vqpl(3),gclgq(ngrf)
real(8), intent(in) :: jlgqr(njcmax,nspecies,ngrf)
complex(8), intent(in) :: ylmgq(lmmaxo,ngrf)
complex(8), intent(in) :: sfacgq(ngrf,natmtot)
integer, intent(in) :: nm
complex(8), intent(inout) :: vchi0(nm,nm,nwrf)
! local variables
logical tq0
integer isym,jk,jkq,iw
integer nst,nstq,ist,jst,kst,lst
integer nm2,ig,jg,i,j,nthd
real(8) vkql(3),eij,t1,t2
complex(8) a(3,3),z1
! automatic arrays
integer idx(nstsv),idxq(nstsv)
integer ngp(nspnfv),ngpq(nspnfv)
! allocatable arrays
integer, allocatable :: igpig(:,:),igpqig(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfir(:,:,:)
complex(8), allocatable :: wfmtq(:,:,:,:),wfirq(:,:,:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:),zrhoig(:)
complex(8), allocatable :: pmat(:,:,:),zw(:),b(:,:)
! check if q=0
tq0=.false.
if (sum(abs(vqpl(:))).lt.epslat) tq0=.true.
! k+q-vector in lattice coordinates
vkql(:)=vkl(:,ik)+vqpl(:)
! equivalent reduced k-points for k and k+q
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
call findkpt(vkql,isym,jkq)
! count and index states at k and k+q in energy window
nst=0
do ist=1,nstsv
if (abs(evalsv(ist,jk)-efermi).lt.emaxrf) then
nst=nst+1
idx(nst)=ist
end if
end do
nstq=0
do jst=1,nstsv
if (abs(evalsv(jst,jkq)-efermi).lt.emaxrf) then
nstq=nstq+1
idxq(nstq)=jst
end if
end do
! generate the wavefunctions for all states at k and k+q in energy window
allocate(igpig(ngkmax,nspnfv))
allocate(wfmt(npcmtmax,natmtot,nspinor,nst),wfir(ngtc,nspinor,nst))
call genwfsvp(.false.,.false.,nst,idx,ngdc,igfc,vkl(:,ik),ngp,igpig,wfmt,ngtc, &
wfir)
deallocate(igpig)
allocate(igpqig(ngkmax,nspnfv))
allocate(wfmtq(npcmtmax,natmtot,nspinor,nstq),wfirq(ngtc,nspinor,nstq))
call genwfsvp(.false.,.false.,nstq,idxq,ngdc,igfc,vkql,ngpq,igpqig,wfmtq,ngtc, &
wfirq)
deallocate(igpqig)
! read the momentum matrix elements from file for q=0
if (tq0) then
allocate(pmat(nstsv,nstsv,3))
call getpmat(vkl(:,ik),pmat)
! divide by unit cell volume
t1=1.d0/omega
pmat(:,:,:)=t1*pmat(:,:,:)
end if
nm2=nm**2
call holdthd(nst,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zrhomt,zrhoir,zrhoig,zw,b) &
!$OMP PRIVATE(jst,kst,lst,t1,t2,eij) &
!$OMP PRIVATE(iw,ig,jg,z1,i,j,a) &
!$OMP NUM_THREADS(nthd)
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
allocate(zrhoig(ngrf),zw(nwrf))
if (tq0.and.t3hw) then
allocate(b(-1:ngrf,-1:ngrf))
else
allocate(b(ngrf,ngrf))
end if
!$OMP DO
do ist=1,nst
kst=idx(ist)
do jst=1,nstq
lst=idxq(jst)
t1=wkptnr*omega*(occsv(kst,jk)-occsv(lst,jkq))
if (abs(t1).lt.1.d-8) cycle
eij=evalsv(kst,jk)-evalsv(lst,jkq)
! scissor operator
if (abs(scsr).gt.1.d-8) then
t2=eij
if (eij.gt.0.d0) then
eij=eij+scsr
else
eij=eij-scsr
end if
t2=eij/t2
! scale the momentum matrix elements for q=0
if (tq0) pmat(kst,lst,:)=t2*pmat(kst,lst,:)
end if
! frequency-dependent part in response function formula for all frequencies
do iw=1,nwrf
zw(iw)=t1/(eij+wrf(iw))
end do
! compute the complex density in G+q-space
call genzrho(.true.,.true.,ngtc,wfmt(:,:,:,ist),wfir(:,:,ist), &
wfmtq(:,:,:,jst),wfirq(:,:,jst),zrhomt,zrhoir)
call zftzf(ngrf,jlgqr,ylmgq,ngrf,sfacgq,zrhomt,zrhoir,zrhoig)
! Hermitian part of body
do jg=1,ngrf
do ig=1,jg-1
b(ig,jg)=conjg(b(jg,ig))
end do
z1=gclgq(jg)*conjg(zrhoig(jg))
do ig=jg,ngrf
b(ig,jg)=gclgq(ig)*zrhoig(ig)*z1
end do
end do
! case of q=0
if (tq0) then
if (t3hw) then
b(-1:1,-1:1)=0.d0
! calculate 3 x ngrf wings of matrix
t1=-sqrt(fourpi)/eij
do i=-1,1
z1=t1*pmat(kst,lst,i+2)
b(i,2:)=z1*conjg(zrhoig(2:))*gclgq(2:)
b(2:,i)=conjg(b(i,2:))
end do
else
! use trace of 3 x 3 head of matrix
t1=sum(dble(pmat(kst,lst,:))**2+aimag(pmat(kst,lst,:))**2)/3.d0
b(1,1)=(fourpi/eij**2)*t1
! wings of matrix
t1=-sqrt(fourpi)/eij
z1=(t1/3.d0)*(pmat(kst,lst,1)+pmat(kst,lst,2)+pmat(kst,lst,3))
b(1,2:)=z1*conjg(zrhoig(2:))*gclgq(2:)
b(2:,1)=conjg(b(1,2:))
end if
end if
! add to body of response function
do iw=1,nwrf
call omp_set_lock(lock(iw))
call zaxpy(nm2,zw(iw),b,1,vchi0(1,1,iw),1)
call omp_unset_lock(lock(iw))
end do
! calculate 3 x 3 head
if (tq0.and.t3hw) then
t1=-fourpi/eij
zw(:)=zw(:)/wrf(:)
do j=1,3
do i=1,3
a(i,j)=t1*pmat(kst,lst,i)*conjg(pmat(kst,lst,j))
end do
end do
do iw=1,nwrf
call omp_set_lock(lock(iw))
vchi0(1:3,1:3,iw)=vchi0(1:3,1:3,iw)+a(1:3,1:3)*zw(iw)
call omp_unset_lock(lock(iw))
end do
end if
! end loop over jst
end do
! end loop over ist
end do
!$OMP END DO
deallocate(zrhomt,zrhoir,zrhoig,zw,b)
!$OMP END PARALLEL
call freethd(nthd)
deallocate(wfmt,wfir,wfmtq,wfirq)
if (tq0) deallocate(pmat)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genspchi0.f90 0000644 0000000 0000000 00000000132 13543334735 015027 x ustar 00 30 mtime=1569569245.077641659
30 atime=1569569241.313644063
30 ctime=1569569245.077641659
elk-6.3.2/src/genspchi0.f90 0000644 0025044 0025044 00000015644 13543334735 017110 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.
!BOP
! !ROUTINE: genspchi0
! !INTERFACE:
subroutine genspchi0(ik,lock,scsr,vqpl,jlgqr,ylmgq,sfacgq,chi0)
! !USES:
use modmain
use modomp
! !INPUT/OUTPUT PARAMETERS:
! ik : k-point from non-reduced set (in,integer)
! lock : OpenMP locks for frequency index of chi0 (in,integer(nwrf))
! scsr : scissor correction (in,real)
! vqpl : input q-point in lattice coordinates (in,real(3))
! jlgqr : spherical Bessel functions evaluated on the coarse radial mesh for
! all species and G+q-vectors (in,real(njcmax,nspecies,ngrf))
! ylmgq : spherical harmonics of the G+q-vectors (in,complex(lmmaxo,ngrf))
! sfacgq : structure factors of G+q-vectors (in,complex(ngrf,natmtot))
! chi0 : spin-dependent Kohn-Sham response function in G-space
! (out,complex(ngrf,4,ngrf,4,nwrf))
! !DESCRIPTION:
! Computes the spin-dependent Kohn-Sham response function:
! \begin{align*}
! \chi_{\alpha\beta,\alpha'\beta'}({\bf r},{\bf r}',\omega)
! & \equiv\frac{\delta\rho_{\alpha\beta}({\bf r},\omega)}
! {\delta v_{\alpha'\beta'}({\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}_{\beta\alpha}({\bf r})|j{\bf k}'\rangle
! \langle j{\bf k}'|\hat{\rho}_{\alpha'\beta'}({\bf r}')|i{\bf k}\rangle}
! {w+(\varepsilon_{i{\bf k}}-\varepsilon_{j{\bf k}'})+i\eta},
! \end{align*}
! where $\alpha$ and $\beta$ are spin-coordinates, $N_k$ is the number of
! $k$-points, $f_{i{\bf k}}$ are the occupancies, $v$ is the Kohn-Sham
! potential and $\hat{\rho}$ is the spin-density operator. With translational
! symmetry in mind, we adopt the following convention for its Fourier
! transform:
! $$ \chi_{\alpha\beta,\alpha'\beta'}({\bf G},{\bf G}',{\bf q},\omega)=
! \frac{1}{\Omega}\int d^3r\,d^3r'\,e^{-i({\bf G}+{\bf q})\cdot{\bf r}}
! e^{i({\bf G}'+{\bf q})\cdot{\bf r}'}
! \chi_{\alpha\beta,\alpha'\beta'}({\bf r},{\bf r}',\omega). $$
! Let
! $$ Z_{i{\bf k},j{\bf k}+{\bf q}}^{\alpha\beta}({\bf G})\equiv
! \int d^3r\,e^{i({\bf G}+{\bf q})\cdot{\bf r}}
! \varphi_{j{\bf k}+{\bf q},\alpha}^*({\bf r})
! \varphi_{i{\bf k},\beta}({\bf r}) $$
! then the response function in $G$-space can be written
! $$ \chi_{\alpha\beta,\alpha'\beta'}({\bf G},{\bf G}',{\bf q},\omega)=
! \frac{1}{N_k\Omega}\sum_{i{\bf k},j{\bf k}+{\bf q}}
! (f_{i{\bf k}}-f_{j{\bf k}})
! \frac{\left[Z_{i{\bf k},j{\bf k}+{\bf q}}^{\alpha\beta}({\bf G})\right]^*
! Z_{i{\bf k},j{\bf k}+{\bf q}}^{\alpha'\beta'}({\bf G}')}
! {w+(\varepsilon_{i{\bf k}}-\varepsilon_{j{\bf k}+{\bf q}})+i\eta}. $$
!
! !REVISION HISTORY:
! Created March 2012 (SS and JKD)
!EOP
!BOC
implicit none
! local variables
integer, intent(in) :: ik
integer(8), intent(in) :: lock(nwrf)
real(8), intent(in) :: scsr,vqpl(3),jlgqr(njcmax,nspecies,ngrf)
complex(8), intent(in) :: ylmgq(lmmaxo,ngrf),sfacgq(ngrf,natmtot)
complex(8), intent(inout) :: chi0(ngrf,4,ngrf,4,nwrf)
! local variables
logical tz(4)
integer isym,jk,jkq,iw
integer nst,nstq,ist,jst,kst,lst
integer ig,jg,a,b,i,j,nthd
real(8) vkql(3),eij,t1
complex(8) z1
! automatic arrays
integer idx(nstsv),idxq(nstsv)
integer ngp(nspnfv),ngpq(nspnfv)
! allocatable arrays
integer, allocatable :: igpig(:,:),igpqig(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfir(:,:,:)
complex(8), allocatable :: wfmtq(:,:,:,:),wfirq(:,:,:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:),zrhoig(:,:)
complex(8), allocatable :: zw(:),c(:,:,:,:)
if (.not.spinpol) then
write(*,*)
write(*,'("Error(genspchi0): spin-unpolarised calculation")')
write(*,*)
stop
end if
! k+q-vector in lattice coordinates
vkql(:)=vkl(:,ik)+vqpl(:)
! equivalent reduced k-points for k and k+q
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
call findkpt(vkql,isym,jkq)
! count and index states at k and k+q in energy window
nst=0
do ist=1,nstsv
if (abs(evalsv(ist,jk)-efermi).lt.emaxrf) then
nst=nst+1
idx(nst)=ist
end if
end do
nstq=0
do jst=1,nstsv
if (abs(evalsv(jst,jkq)-efermi).lt.emaxrf) then
nstq=nstq+1
idxq(nstq)=jst
end if
end do
! generate the wavefunctions for all states at k and k+q in energy window
allocate(igpig(ngkmax,nspnfv))
allocate(wfmt(npcmtmax,natmtot,nspinor,nst),wfir(ngtc,nspinor,nst))
call genwfsvp(.false.,.false.,nst,idx,ngdc,igfc,vkl(:,ik),ngp,igpig,wfmt,ngtc, &
wfir)
deallocate(igpig)
allocate(igpqig(ngkmax,nspnfv))
allocate(wfmtq(npcmtmax,natmtot,nspinor,nstq),wfirq(ngtc,nspinor,nstq))
call genwfsvp(.false.,.false.,nstq,idxq,ngdc,igfc,vkql,ngpq,igpqig,wfmtq,ngtc, &
wfirq)
deallocate(igpqig)
call holdthd(nst,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zrhomt,zrhoir,zrhoig,zw,c) &
!$OMP PRIVATE(jst,kst,lst,t1,eij,iw,i,j) &
!$OMP PRIVATE(a,b,tz,ig,jg,z1) &
!$OMP NUM_THREADS(nthd)
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
allocate(zrhoig(ngrf,4),zw(nwrf),c(ngrf,4,ngrf,4))
!$OMP DO
do ist=1,nst
kst=idx(ist)
do jst=1,nstq
lst=idxq(jst)
t1=wkptnr*omega*(occsv(kst,jk)-occsv(lst,jkq))
if (abs(t1).lt.1.d-8) cycle
eij=evalsv(kst,jk)-evalsv(lst,jkq)
! scissor operator
if (abs(scsr).gt.1.d-8) then
if (eij.gt.0.d0) then
eij=eij+scsr
else
eij=eij-scsr
end if
end if
! frequency-dependent part in response function formula for all frequencies
do iw=1,nwrf
zw(iw)=t1/(eij+wrf(iw))
end do
! compute the complex density in G+q-space
i=0
do a=1,2
do b=1,2
i=i+1
! find which contributions are zero for collinear case
tz(i)=.false.
if (.not.ncmag) then
if (((a.eq.1).and.(kst.gt.nstfv)).or. &
((a.eq.2).and.(kst.le.nstfv)).or. &
((b.eq.1).and.(lst.gt.nstfv)).or. &
((b.eq.2).and.(lst.le.nstfv))) then
tz(i)=.true.
cycle
end if
end if
call genzrho(.true.,.false.,ngtc,wfmt(:,:,a,ist),wfir(:,a,ist), &
wfmtq(:,:,b,jst),wfirq(:,b,jst),zrhomt,zrhoir)
call zftzf(ngrf,jlgqr,ylmgq,ngrf,sfacgq,zrhomt,zrhoir,zrhoig(:,i))
end do
end do
! Hermitian part of matrix
do j=1,4
if (tz(j)) cycle
do jg=1,ngrf
z1=conjg(zrhoig(jg,j))
do i=1,4
if (tz(i)) cycle
do ig=1,ngrf
c(ig,i,jg,j)=zrhoig(ig,i)*z1
end do
end do
end do
end do
do iw=1,nwrf
z1=zw(iw)
call omp_set_lock(lock(iw))
do j=1,4
if (tz(j)) cycle
do jg=1,ngrf
do i=1,4
if (tz(i)) cycle
call zaxpy(ngrf,z1,c(:,i,jg,j),1,chi0(:,i,jg,j,iw),1)
end do
end do
end do
call omp_unset_lock(lock(iw))
end do
! end loop over jst
end do
! end loop over ist
end do
!$OMP END DO
deallocate(zrhomt,zrhoir,zrhoig,zw,c)
!$OMP END PARALLEL
call freethd(nthd)
deallocate(wfmt,wfmtq,wfir,wfirq)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/vclcore.f90 0000644 0000000 0000000 00000000131 13543334735 014603 x ustar 00 30 mtime=1569569245.081641656
29 atime=1569569241.31864406
30 ctime=1569569245.081641656
elk-6.3.2/src/vclcore.f90 0000644 0025044 0025044 00000005646 13543334735 016666 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.
subroutine vclcore(wfmt,vmat)
use modmain
use modomp
implicit none
! arguments
complex(8), intent(in) :: wfmt(npcmtmax,natmtot,nspinor,nstsv)
complex(8), intent(inout) :: vmat(nstsv,nstsv)
! local variables
integer ist1,ist2,ist3
integer is,ia,ias,m,nthd
integer nrc,nrci,npc
complex(8) z1
! allocatable arrays
complex(8), allocatable :: zrhomt(:,:),wfcr(:,:),zfmt(:)
! external functions
complex(8) zfmtinp
external zfmtinp
allocate(zrhomt(npcmtmax,nstsv),wfcr(npcmtmax,2))
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
do ist3=1,nstsp(is)
if (spcore(ist3,is)) then
do m=-ksp(ist3,is),ksp(ist3,is)-1
! generate the core wavefunction in spherical coordinates (pass in m-1/2)
call wavefcr(.false.,lradstp,is,ia,ist3,m,npcmtmax,wfcr)
call holdthd(nstsv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zfmt) &
!$OMP NUM_THREADS(nthd)
allocate(zfmt(npcmtmax))
!$OMP DO
do ist1=1,nstsv
! calculate the complex overlap density in spherical harmonics
if (spinpol) then
call zrho2(npc,wfcr,wfcr(:,2),wfmt(:,ias,1,ist1), &
wfmt(:,ias,2,ist1),zfmt)
else
call zrho1(npc,wfcr,wfmt(:,ias,1,ist1),zfmt)
end if
call zfsht(nrc,nrci,zfmt,zrhomt(:,ist1))
end do
!$OMP END DO
deallocate(zfmt)
!$OMP END PARALLEL
call freethd(nthd)
call holdthd(nstsv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(zfmt,ist1,z1) &
!$OMP NUM_THREADS(nthd)
allocate(zfmt(npcmtmax))
!$OMP DO
do ist2=1,nstsv
call zpotclmt(nrc,nrci,nrcmtmax,rlcmt(:,:,is),wprcmt(:,:,is), &
zrhomt(:,ist2),zfmt)
do ist1=1,ist2
z1=zfmtinp(nrc,nrci,wrcmt(:,is),zrhomt(:,ist1),zfmt)
vmat(ist1,ist2)=vmat(ist1,ist2)-z1
end do
end do
!$OMP END DO
deallocate(zfmt)
!$OMP END PARALLEL
call freethd(nthd)
end do
end if
end do
end do
end do
! set the lower triangular part of the matrix
do ist1=1,nstsv
do ist2=1,ist1-1
vmat(ist1,ist2)=conjg(vmat(ist2,ist1))
end do
end do
! scale the Coulomb matrix elements in the case of a hybrid functional
if (hybrid) vmat(:,:)=hybridc*vmat(:,:)
deallocate(zrhomt,wfcr)
return
contains
subroutine zrho1(n,x,y,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x(n),y(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x(:))*y(:)
return
end subroutine
subroutine zrho2(n,x1,x2,y1,y2,z)
implicit none
integer, intent(in) :: n
complex(8), intent(in) :: x1(n),x2(n),y1(n),y2(n)
complex(8), intent(out) :: z(n)
z(:)=conjg(x1(:))*y1(:)+conjg(x2(:))*y2(:)
return
end subroutine
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmlxbse.f90 0000644 0000000 0000000 00000000132 13543334735 014611 x ustar 00 30 mtime=1569569245.085641654
30 atime=1569569241.323644056
30 ctime=1569569245.085641654
elk-6.3.2/src/hmlxbse.f90 0000644 0025044 0025044 00000001303 13543334735 016655 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine hmlxbse
use modmain
use modmpi
use modomp
implicit none
! local variables
integer ik2,nthd
call holdthd(nkptnr/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik2=1,nkptnr
! distribute among MPI processes
if (mod(ik2-1,np_mpi).ne.lp_mpi) cycle
!$OMP CRITICAL(hmlxbse_)
write(*,'("Info(hmlxbse): ",I6," of ",I6," k-points")') ik2,nkptnr
!$OMP END CRITICAL(hmlxbse_)
call hmlxbsek(ik2)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmlxbsek.f90 0000644 0000000 0000000 00000000130 13543334735 014762 x ustar 00 29 mtime=1569569245.09064165
30 atime=1569569241.327644054
29 ctime=1569569245.09064165
elk-6.3.2/src/hmlxbsek.f90 0000644 0025044 0025044 00000006660 13543334735 017043 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 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.
subroutine hmlxbsek(ik2)
use modmain
implicit none
! arguments
integer, intent(in) :: ik2
! local variables
integer ik1,ist1,ist2,jst1,jst2
integer i1,i2,j1,j2,a1,a2,b1,b2
integer is,ias,l
real(8) t0
complex(8) z1
! automatic arrays
integer idx(nstsv),ngp(nspnfv)
! allocatable arrays
integer, allocatable :: igpig(:,:)
complex(8), allocatable :: wfmt1(:,:,:,:),wfir1(:,:,:)
complex(8), allocatable :: wfmt2(:,:,:,:),wfir2(:,:,:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:)
complex(8), allocatable :: zvclmt(:,:,:),zvclir(:,:)
complex(8), allocatable :: zfmt(:)
! external functions
complex(8) zfinp
external zfinp
! allocate local arrays
allocate(igpig(ngkmax,nspnfv))
allocate(wfmt1(npcmtmax,natmtot,nspinor,nstsv),wfir1(ngtc,nspinor,nstsv))
allocate(wfmt2(npcmtmax,natmtot,nspinor,nstsv),wfir2(ngtc,nspinor,nstsv))
allocate(zrhomt(npcmtmax,natmtot),zrhoir(ngtc))
allocate(zvclmt(npcmtmax,natmtot,nvcbse),zvclir(ngtc,nvcbse))
allocate(zfmt(npcmtmax))
! index to all states
do ist1=1,nstsv
idx(ist1)=ist1
end do
! calculate the wavefunctions for all states of k-point ik2
call genwfsvp(.false.,.false.,nstsv,idx,ngdc,igfc,vkl(:,ik2),ngp,igpig,wfmt2, &
ngtc,wfir2)
l=0
do i2=1,nvbse
ist2=istbse(i2,ik2)
do j2=1,ncbse
jst2=jstbse(j2,ik2)
a2=ijkbse(i2,j2,ik2)
l=l+1
! calculate the complex overlap density
call genzrho(.true.,.true.,ngtc,wfmt2(:,:,:,ist2),wfir2(:,:,ist2), &
wfmt2(:,:,:,jst2),wfir2(:,:,jst2),zrhomt,zrhoir)
! compute the Coulomb potential
call genzvclmt(nrcmt,nrcmti,nrcmtmax,rlcmt,wprcmt,npcmtmax,zrhomt, &
zvclmt(:,:,l))
call zpotcoul(nrcmt,nrcmti,npcmt,npcmti,nrcmtmax,rlcmt,ngdc,igfc,ngvc,gc, &
gclg,ngvec,jlgrmt,ylmg,sfacg,zrhoir,npcmtmax,zvclmt(:,:,l),zvclir(:,l))
end do
end do
t0=occmax*wkptnr
! start loop over ik1
do ik1=1,nkptnr
if (ik1.eq.ik2) then
wfmt1(:,:,:,:)=wfmt2(:,:,:,:)
wfir1(:,:,:)=wfir2(:,:,:)
else
call genwfsvp(.false.,.false.,nstsv,idx,ngdc,igfc,vkl(:,ik1),ngp,igpig, &
wfmt1,ngtc,wfir1)
end if
do i1=1,nvbse
ist1=istbse(i1,ik1)
do j1=1,ncbse
jst1=jstbse(j1,ik1)
a1=ijkbse(i1,j1,ik1)
! calculate the complex overlap density
call genzrho(.true.,.true.,ngtc,wfmt1(:,:,:,ist1),wfir1(:,:,ist1), &
wfmt1(:,:,:,jst1),wfir1(:,:,jst1),zrhomt,zrhoir)
l=0
do i2=1,nvbse
ist2=istbse(i2,ik2)
do j2=1,ncbse
jst2=jstbse(j2,ik2)
a2=ijkbse(i2,j2,ik2)
l=l+1
! compute the matrix element
z1=t0*zfinp(zrhomt,zrhoir,zvclmt(:,:,l),zvclir(:,l))
hmlbse(a1,a2)=hmlbse(a1,a2)+z1
! compute off-diagonal blocks if required
if (bsefull) then
b1=a1+nbbse
b2=a2+nbbse
hmlbse(b1,b2)=hmlbse(b1,b2)-conjg(z1)
! conjugate the potential
do ias=1,natmtot
is=idxis(ias)
call zfmtconj(nrcmt(is),nrcmti(is),npcmt(is),zvclmt(:,ias,l))
end do
zvclir(:,l)=conjg(zvclir(:,l))
z1=t0*zfinp(zrhomt,zrhoir,zvclmt(:,:,l),zvclir(:,l))
hmlbse(a1,b2)=hmlbse(a1,b2)+z1
hmlbse(b1,a2)=hmlbse(b1,a2)-conjg(z1)
end if
end do
end do
end do
end do
end do
deallocate(igpig,wfmt1,wfmt2,wfir1,wfir2)
deallocate(zrhomt,zrhoir,zvclmt,zvclir,zfmt)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genvmatk.f90 0000644 0000000 0000000 00000000132 13543334735 014763 x ustar 00 30 mtime=1569569245.094641648
30 atime=1569569241.332644051
30 ctime=1569569245.094641648
elk-6.3.2/src/genvmatk.f90 0000644 0025044 0025044 00000005255 13543334735 017041 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 genvmatk(vmt,vir,ngp,igpig,wfmt,ld,wfgp,vmat)
use modmain
use modomp
implicit none
! arguments
real(8), intent(in) :: vmt(npcmtmax,natmtot),vir(ngtot)
integer, intent(in) :: ngp(nspnfv),igpig(ngkmax,nspnfv)
complex(8), intent(in) :: wfmt(npcmtmax,natmtot,nspinor,nstsv)
integer, intent(in) :: ld
complex(8), intent(in) :: wfgp(ld,nspinor,nstsv)
complex(8), intent(out) :: vmat(nstsv,nstsv)
! local variables
integer ist,jst,ispn,jspn
integer is,ias,nrc,nrci
integer npc,igp,nthd
! allocatable arrays
complex(8), allocatable :: wfmt1(:),wfir(:),z(:)
! external functions
complex(8) zfcmtinp,zdotc
external zfcmtinp,zdotc
! zero the matrix elements
vmat(:,:)=0.d0
!-------------------------!
! muffin-tin part !
!-------------------------!
call holdthd(nstsv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfmt1,ispn,ias,is) &
!$OMP PRIVATE(nrc,nrci,npc,ist) &
!$OMP NUM_THREADS(nthd)
allocate(wfmt1(npcmtmax))
!$OMP DO
do jst=1,nstsv
do ispn=1,nspinor
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
! apply potential to wavefunction
wfmt1(1:npc)=vmt(1:npc,ias)*wfmt(1:npc,ias,ispn,jst)
do ist=1,jst
! compute inner product (functions are in spherical coordinates)
vmat(ist,jst)=vmat(ist,jst)+zfcmtinp(nrc,nrci,wrcmt(:,is), &
wfmt(:,ias,ispn,ist),wfmt1)
end do
end do
end do
end do
!$OMP END DO
deallocate(wfmt1)
!$OMP END PARALLEL
call freethd(nthd)
!---------------------------!
! interstitial part !
!---------------------------!
call holdthd(nstsv,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(wfir,z,ispn,jspn) &
!$OMP PRIVATE(igp,ist) &
!$OMP NUM_THREADS(nthd)
allocate(wfir(ngtot),z(ngkmax))
!$OMP DO
do jst=1,nstsv
do ispn=1,nspinor
jspn=jspnfv(ispn)
! Fourier transform wavefunction to real-space
wfir(:)=0.d0
do igp=1,ngp(jspn)
wfir(igfft(igpig(igp,jspn)))=wfgp(igp,ispn,jst)
end do
call zfftifc(3,ngridg,1,wfir)
! apply potential to wavefunction
wfir(:)=vir(:)*wfir(:)
! Fourier transform to G+p-space
call zfftifc(3,ngridg,-1,wfir)
do igp=1,ngp(jspn)
z(igp)=wfir(igfft(igpig(igp,jspn)))
end do
do ist=1,jst
! compute inner product
vmat(ist,jst)=vmat(ist,jst)+zdotc(ngp(jspn),wfgp(:,ispn,ist),1,z,1)
end do
end do
end do
!$OMP END DO
deallocate(wfir,z)
!$OMP END PARALLEL
call freethd(nthd)
! lower triangular part
do ist=1,nstsv
do jst=1,ist-1
vmat(ist,jst)=conjg(vmat(jst,ist))
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/writeepsinv.f90 0000644 0000000 0000000 00000000132 13543334735 015526 x ustar 00 30 mtime=1569569245.098641645
30 atime=1569569241.337644047
30 ctime=1569569245.098641645
elk-6.3.2/src/writeepsinv.f90 0000644 0025044 0025044 00000002033 13543334735 017573 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.
subroutine writeepsinv
use modmain
use modmpi
implicit none
! local variables
integer ik
! initialise global variables
call init0
call init1
call init2
call init3
! read density and potentials from file
call readstate
! read Fermi energy from file
call readfermi
! find the new linearisation energies
call linengy
! generate the APW radial functions
call genapwfr
! generate the local-orbital radial functions
call genlofr
! get the eigenvalues and occupancies from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! generate the inverse dielectric function and write to file
call epsinv
if (mp_mpi) then
write(*,*)
write(*,'("Info(writeepsinv):")')
write(*,'(" inverse RPA dielectric function, eps^(-1)(G,G'',q,w), written to &
&EPSINV.OUT")')
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/putepsinv.f90 0000644 0000000 0000000 00000000132 13543334735 015204 x ustar 00 30 mtime=1569569245.103641642
30 atime=1569569241.342644044
30 ctime=1569569245.103641642
elk-6.3.2/src/putepsinv.f90 0000644 0025044 0025044 00000001536 13543334735 017260 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 putepsinv(iq,epsi)
use modmain
implicit none
! arguments
integer, intent(in) :: iq
complex(8), intent(in) :: epsi(ngrf,ngrf,nwrf)
! local variables
integer recl,i
! determine the record length for EPSINV.OUT
inquire(iolength=recl) vql(:,iq),ngrf,nwrf,epsi
!$OMP CRITICAL(u180)
do i=1,2
open(180,file='EPSINV.OUT',form='UNFORMATTED',access='DIRECT',recl=recl, &
err=10)
write(180,rec=iq,err=10) vql(:,iq),ngrf,nwrf,epsi
close(180)
exit
10 continue
if (i.eq.2) then
write(*,*)
write(*,'("Error(putepsinv): unable to write to EPSINV.OUT")')
write(*,*)
stop
end if
close(180)
end do
!$OMP END CRITICAL(u180)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/curden.f90 0000644 0000000 0000000 00000000132 13543334735 014427 x ustar 00 30 mtime=1569569245.107641639
30 atime=1569569241.347644041
30 ctime=1569569245.107641639
elk-6.3.2/src/curden.f90 0000644 0025044 0025044 00000006437 13543334735 016510 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 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.
subroutine curden(afield)
use modmain
use modmpi
use modomp
implicit none
! arguments
real(8), intent(in) :: afield(3)
! local variables
integer ik,is,ias,ispn
integer nr,nri,iro,np
integer nrc,nrci,npc
integer ir,n,i,nthd
real(8) ca,t1
! allocatable arrays
real(8), allocatable :: rfmt(:)
! external functions
real(8) rfint
external rfint
! coupling constant of the external A-field (1/c)
ca=1.d0/solsc
! set the current density to zero
do i=1,3
do ias=1,natmtot
is=idxis(ias)
cdmt(1:npcmt(is),ias,i)=0.d0
end do
end do
cdir(:,:)=0.d0
! current density cannot be computed if wavefunctions do not exist
if (iscl.le.0) return
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
call curdenk(ik)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! convert muffin-tin current density to spherical harmonics
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(rfmt,is,nrc,nrci,npc,i) &
!$OMP NUM_THREADS(nthd)
allocate(rfmt(npcmtmax))
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do i=1,3
rfmt(1:npc)=cdmt(1:npc,ias,i)
call rfsht(nrc,nrci,rfmt,cdmt(:,ias,i))
end do
end do
!$OMP END DO
deallocate(rfmt)
!$OMP END PARALLEL
call freethd(nthd)
! symmetrise the current density
call symrvf(.false.,.true.,nrcmt,nrcmti,npcmt,npmtmax,cdmt,cdir)
! convert the current density from a coarse to a fine radial mesh
call holdthd(3,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do i=1,3
call rfmtctof(cdmt(:,:,i))
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
! add current densities from each process and redistribute
if (np_mpi.gt.1) then
n=npmtmax*natmtot*3
call mpi_allreduce(mpi_in_place,cdmt,n,mpi_double_precision,mpi_sum,mpicom, &
ierror)
n=ngtot*3
call mpi_allreduce(mpi_in_place,cdir,n,mpi_double_precision,mpi_sum,mpicom, &
ierror)
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
! add vector potential contribution to make current gauge invariant
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(rfmt,is,nr,nri,np) &
!$OMP PRIVATE(iro,ispn,i,ir,t1) &
!$OMP NUM_THREADS(nthd)
allocate(rfmt(npmtmax))
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
np=npmt(is)
iro=nri+1
! remove the core density from the muffin-tin density
call dcopy(np,rhomt(:,ias),1,rfmt,1)
do ispn=1,nspncr
i=1
do ir=1,nri
rfmt(i)=rfmt(i)-rhocr(ir,ias,ispn)
i=i+lmmaxi
end do
do ir=iro,nr
rfmt(i)=rfmt(i)-rhocr(ir,ias,ispn)
i=i+lmmaxo
end do
end do
do i=1,3
t1=-ca*afield(i)
call daxpy(np,t1,rfmt,1,cdmt(:,ias,i),1)
end do
end do
!$OMP END DO
deallocate(rfmt)
!$OMP END PARALLEL
call freethd(nthd)
do i=1,3
t1=-ca*afield(i)
call daxpy(ngtot,t1,rhoir,1,cdir(:,i),1)
end do
! compute the total current in the unit cell
do i=1,3
curtot(i)=rfint(cdmt(:,:,i),cdir(:,i))
end do
! total current magnitude
curtotm=sqrt(curtot(1)**2+curtot(2)**2+curtot(3)**2)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/curdenk.f90 0000644 0000000 0000000 00000000132 13543334735 014602 x ustar 00 30 mtime=1569569245.112641636
30 atime=1569569241.351644038
30 ctime=1569569245.112641636
elk-6.3.2/src/curdenk.f90 0000644 0025044 0025044 00000007126 13543334735 016657 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 curdenk(ik)
use modmain
implicit none
! arguments
integer, intent(in) :: ik
! local variables
integer ispn,jspn,nst,ist,jst
integer is,ia,ias,nrc,nrci,npc
integer igk,ifg,i
real(8) wo
complex(8) z1
! automatic arrays
integer idx(nstsv)
! allocatable arrays
real(8), allocatable :: rfmt(:)
complex(8), allocatable :: apwalm(:,:,:,:,:),evecfv(:,:),evecsv(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfgp(:,:,:)
complex(8), allocatable :: gzfmt(:,:),zfmt1(:),zfmt2(:)
complex(8), allocatable :: zfft1(:),zfft2(:)
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
allocate(evecfv(nmatmax,nstfv),evecsv(nstsv,nstsv))
! find the matching coefficients
do ispn=1,nspnfv
call match(ngk(ispn,ik),vgkc(:,:,ispn,ik),gkc(:,ispn,ik), &
sfacgk(:,:,ispn,ik),apwalm(:,:,:,:,ispn))
end do
! get the eigenvectors from file
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! count and index the occupied states
nst=0
do ist=1,nstsv
if (abs(occsv(ist,ik)).lt.epsocc) cycle
nst=nst+1
idx(nst)=ist
end do
! calculate the second-variational wavefunctions for occupied states
allocate(wfmt(npcmtmax,natmtot,nspinor,nst),wfgp(ngkmax,nspinor,nst))
call genwfsv(.true.,.true.,nst,idx,ngridg,igfft,ngk(:,ik),igkig(:,:,ik), &
apwalm,evecfv,evecsv,wfmt,ngkmax,wfgp)
deallocate(apwalm,evecfv,evecsv)
!------------------------------------!
! muffin-tin current density !
!------------------------------------!
allocate(rfmt(npcmtmax))
allocate(gzfmt(npcmtmax,3),zfmt1(npcmtmax),zfmt2(npcmtmax))
do ist=1,nst
jst=idx(ist)
wo=wkpt(ik)*occsv(jst,ik)
do ispn=1,nspinor
do is=1,nspecies
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
do ia=1,natoms(is)
ias=idxas(ia,is)
! compute the gradient of the wavefunction
call gradzfmt(nrc,nrci,rlcmt(:,1,is),rlcmt(:,-1,is), &
wfmt(:,ias,ispn,ist),npcmtmax,gzfmt)
! convert wavefunction to spherical coordinates and conjugate
call zbsht(nrc,nrci,wfmt(:,ias,ispn,ist),zfmt1)
zfmt1(1:npc)=conjg(zfmt1(1:npc))
do i=1,3
! convert wavefunction gradient to spherical coordinates
call zbsht(nrc,nrci,gzfmt(:,i),zfmt2)
! compute the partial current density
rfmt(1:npc)=aimag(zfmt1(1:npc)*zfmt2(1:npc))
!$OMP CRITICAL(currentk_1)
call daxpy(npc,wo,rfmt,1,cdmt(:,ias,i),1)
!$OMP END CRITICAL(currentk_1)
end do
end do
end do
end do
end do
deallocate(wfmt,rfmt,gzfmt,zfmt1,zfmt2)
!--------------------------------------!
! interstitial current density !
!--------------------------------------!
allocate(zfft1(ngtot),zfft2(ngtot))
do ist=1,nst
jst=idx(ist)
wo=wkpt(ik)*occsv(jst,ik)/omega
do ispn=1,nspinor
jspn=jspnfv(ispn)
! Fourier transform to real-space and conjugate
zfft1(:)=0.d0
do igk=1,ngk(jspn,ik)
ifg=igfft(igkig(igk,jspn,ik))
zfft1(ifg)=wfgp(igk,ispn,ist)
end do
call zfftifc(3,ngridg,1,zfft1)
zfft1(:)=conjg(zfft1(:))
do i=1,3
! compute the gradient of the wavefunction
zfft2(:)=0.d0
do igk=1,ngk(jspn,ik)
ifg=igfft(igkig(igk,jspn,ik))
z1=wfgp(igk,ispn,ist)
zfft2(ifg)=vgkc(i,igk,jspn,ik)*cmplx(-aimag(z1),dble(z1),8)
end do
call zfftifc(3,ngridg,1,zfft2)
!$OMP CRITICAL(currentk_2)
cdir(:,i)=cdir(:,i)+wo*aimag(zfft1(:)*zfft2(:))
!$OMP END CRITICAL(currentk_2)
end do
end do
end do
deallocate(wfgp,zfft1,zfft2)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hflocal.f90 0000644 0000000 0000000 00000000132 13543334735 014557 x ustar 00 30 mtime=1569569245.116641634
30 atime=1569569241.356644035
30 ctime=1569569245.116641634
elk-6.3.2/src/hflocal.f90 0000644 0025044 0025044 00000003161 13543334735 016627 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.
subroutine hflocal(hyb,vmt,vir,bmt,bir)
use modmain
implicit none
! arguments
logical, intent(in) :: hyb
real(8), intent(out) :: vmt(npcmtmax,natmtot),vir(ngtot)
real(8), intent(out) :: bmt(npcmtmax,natmtot,ndmag),bir(ngtot,ndmag)
! local variables
integer idm,is,ias
integer np,nrc,nrci
! automatic arrays
real(8) rfmt1(npmtmax),rfmt2(npcmtmax)
! compute the Coulomb potential
call potcoul
! convert to spherical coordinates and store in output arrays
if (hyb) then
! hybrid functional case
call potxc(.true.,xctype,rhomt,rhoir,magmt,magir,taumt,tauir,exmt,exir,ecmt, &
ecir,vxcmt,vxcir,bxcmt,bxcir,wxcmt,wxcir)
do ias=1,natmtot
is=idxis(ias)
np=npmt(is)
nrc=nrcmt(is)
nrci=nrcmti(is)
rfmt1(1:np)=vclmt(1:np,ias)+vxcmt(1:np,ias)
call rfmtftoc(nrc,nrci,rfmt1,rfmt2)
call rbsht(nrc,nrci,rfmt2,vmt(:,ias))
end do
vir(:)=(vclir(:)+vxcir(:))*cfunir(:)
if (spinpol) then
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
call rfmtftoc(nrc,nrci,bxcmt(:,ias,idm),rfmt1)
call rbsht(nrc,nrci,rfmt1,bmt(:,ias,idm))
end do
bir(:,idm)=bxcir(:,idm)*cfunir(:)
end do
end if
else
! normal Hartree-Fock case
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
call rfmtftoc(nrc,nrci,vclmt(:,ias),rfmt1)
call rbsht(nrc,nrci,rfmt1,vmt(:,ias))
end do
vir(:)=vclir(:)*cfunir(:)
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/dielectric.f90 0000644 0000000 0000000 00000000132 13543334735 015256 x ustar 00 30 mtime=1569569245.120641631
30 atime=1569569241.360644033
30 ctime=1569569245.120641631
elk-6.3.2/src/dielectric.f90 0000644 0025044 0025044 00000011657 13543334735 017337 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2009 S. Sharma, J. K. Dewhurst 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: dielectric
! !INTERFACE:
subroutine dielectric
! !USES:
use modmain
use modtest
use modomp
! !DESCRIPTION:
! Computes the dielectric tensor, optical conductivity and plasma frequency.
! The formulae are taken from {\it Physica Scripta} {\bf T109}, 170 (2004).
!
! !REVISION HISTORY:
! Created November 2005 (SS and JKD)
! Added plasma frequency and intraband contribution (S. Lebegue)
! Complete rewrite, 2008 (JKD)
! Fixed problem with plasma frequency, 2009 (Marty Blaber and JKD)
! Parallelised, 2009 (M. Blaber)
!EOP
!BOC
implicit none
! local variables
integer ik,jk,ist,jst
integer iw,i,j,l,nthd
real(8) w1,w2,wplas
real(8) eji,x,t1,t2
complex(8) eta,z1
character(256) fname
! allocatable arrays
real(8), allocatable :: w(:)
complex(8), allocatable :: pmat(:,:,:),sigma(:)
! external functions
real(8) sdelta
external sdelta
! initialise universal variables
call init0
call init1
! read Fermi energy from file
call readfermi
! get the eigenvalues and occupancies from file
do ik=1,nkpt
call getevalsv(filext,ik,vkl(:,ik),evalsv(:,ik))
call getoccsv(filext,ik,vkl(:,ik),occsv(:,ik))
end do
! allocate local arrays
allocate(w(nwplot))
allocate(sigma(nwplot))
! generate energy grid (always non-negative)
w1=max(wplot(1),0.d0)
w2=max(wplot(2),w1)
t1=(w2-w1)/dble(nwplot)
do iw=1,nwplot
w(iw)=w1+t1*dble(iw-1)
end do
! i divided by the complex relaxation time
eta=cmplx(0.d0,swidth,8)
! loop over dielectric tensor components
do l=1,noptcomp
i=optcomp(1,l)
j=optcomp(2,l)
wplas=0.d0
sigma(:)=0.d0
! parallel loop over non-reduced k-points
call holdthd(nkptnr,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(pmat,jk,ist,jst) &
!$OMP PRIVATE(z1,eji,t1,x) &
!$OMP NUM_THREADS(nthd)
allocate(pmat(nstsv,nstsv,3))
!$OMP DO
do ik=1,nkptnr
! equivalent reduced k-point
jk=ivkik(ivk(1,ik),ivk(2,ik),ivk(3,ik))
! read in the momentum matrix elements
call getpmat(vkl(:,ik),pmat)
! valance states
do ist=1,nstsv
! conduction states
do jst=1,nstsv
z1=pmat(ist,jst,i)*conjg(pmat(ist,jst,j))
eji=evalsv(jst,jk)-evalsv(ist,jk)
if ((evalsv(ist,jk).le.efermi).and.(evalsv(jst,jk).gt.efermi)) then
! scissor correction
if (scissor.ne.0.d0) then
t1=(eji+scissor)/eji
z1=z1*t1**2
eji=eji+scissor
end if
end if
if (abs(eji).gt.1.d-8) then
t1=occsv(ist,jk)*(1.d0-occsv(jst,jk)/occmax)/eji
!$OMP CRITICAL(dielectric_1)
sigma(:)=sigma(:)+t1*(z1/(w(:)-eji+eta)+conjg(z1)/(w(:)+eji+eta))
!$OMP END CRITICAL(dielectric_1)
end if
! add to the plasma frequency
if (intraband) then
if (i.eq.j) then
if (ist.eq.jst) then
x=(evalsv(ist,jk)-efermi)/swidth
!$OMP CRITICAL(dielectric_2)
wplas=wplas+wkptnr*dble(z1)*sdelta(stype,x)/swidth
!$OMP END CRITICAL(dielectric_2)
end if
end if
end if
end do
end do
end do
!$OMP END DO
deallocate(pmat)
!$OMP END PARALLEL
call freethd(nthd)
z1=zi*wkptnr/omega
sigma(:)=z1*sigma(:)
! intraband contribution
if (intraband) then
if (i.eq.j) then
wplas=sqrt(occmax*abs(wplas)*fourpi/omega)
! write the plasma frequency to file
write(fname,'("PLASMA_",2I1,".OUT")') i,j
open(50,file=trim(fname),form='FORMATTED')
write(50,'(G18.10," : plasma frequency")') wplas
close(50)
! add the intraband contribution to sigma
t1=wplas**2/fourpi
do iw=1,nwplot
sigma(iw)=sigma(iw)+t1/(swidth-zi*w(iw))
end do
end if
end if
! write the optical conductivity to file
write(fname,'("SIGMA_",2I1,".OUT")') i,j
open(50,file=trim(fname),form='FORMATTED')
do iw=1,nwplot
write(50,'(2G18.10)') w(iw),dble(sigma(iw))
end do
write(50,*)
do iw=1,nwplot
write(50,'(2G18.10)') w(iw),aimag(sigma(iw))
end do
close(50)
! write the dielectric function to file
write(fname,'("EPSILON_",2I1,".OUT")') i,j
open(50,file=trim(fname),form='FORMATTED')
t1=0.d0
if (i.eq.j) t1=1.d0
do iw=1,nwplot
t2=t1-fourpi*aimag(sigma(iw)/(w(iw)+eta))
write(50,'(2G18.10)') w(iw),t2
end do
write(50,*)
do iw=1,nwplot
t2=fourpi*dble(sigma(iw)/(w(iw)+eta))
write(50,'(2G18.10)') w(iw),t2
end do
close(50)
! write sigma to test file
call writetest(121,'optical conductivity',nv=nwplot,tol=1.d-2,zva=sigma)
! end loop over tensor components
end do
write(*,*)
write(*,'("Info(dielectric):")')
write(*,'(" dielectric tensor written to EPSILON_ij.OUT")')
write(*,'(" optical conductivity written to SIGMA_ij.OUT")')
if (intraband) then
write(*,'(" plasma frequency written to PLASMA_ij.OUT")')
end if
write(*,'(" for components")')
do l=1,noptcomp
write(*,'(" i = ",I1,", j = ",I1)') optcomp(1:2,l)
end do
deallocate(w,sigma)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/bdipole.f90 0000644 0000000 0000000 00000000131 13543334735 014564 x ustar 00 30 mtime=1569569245.125641628
29 atime=1569569241.36564403
30 ctime=1569569245.125641628
elk-6.3.2/src/bdipole.f90 0000644 0025044 0025044 00000005371 13543334735 016642 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 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.
subroutine bdipole
use modmain
implicit none
! local variables
integer idm,is,ias
integer nrc,nrci,npc
real(8) cb,t1
! automatic arrays
real(8), allocatable :: rvfmt(:,:,:),rvfir(:,:)
real(8), allocatable :: rfmt1(:),rfmt2(:)
complex(8), allocatable :: zrhomt(:,:),zrhoir(:)
complex(8), allocatable :: zvclmt(:,:),zvclir(:)
if (.not.ncmag) then
write(*,*)
write(*,'("Error(bdipole): non-collinear magnetism required for inclusion of &
&the dipole field")')
write(*,*)
stop
end if
! prefactor for the spin dipole magnetic field
cb=gfacte/(4.d0*solsc)
! compute the gauge invariant current density if required
if (tcden) call curden(afieldc)
! allocate local arrays
allocate(rvfmt(npmtmax,natmtot,3),rvfir(ngtot,3))
allocate(zrhomt(npmtmax,natmtot),zrhoir(ngtot))
allocate(zvclmt(npmtmax,natmtot),zvclir(ngtot))
! compute the curl of the magnetisation density, i.e. the magnetisation current
call curlrvf(magmt,magir,rvfmt,rvfir)
! negate and multiply by prefactor
rvfmt(:,:,:)=-cb*rvfmt(:,:,:)
rvfir(:,:)=-cb*rvfir(:,:)
! add the current density if required
if (tcden) then
t1=1.d0/solsc
rvfmt(:,:,:)=rvfmt(:,:,:)+t1*cdmt(:,:,:)
rvfir(:,:)=rvfir(:,:)+t1*cdir(:,:)
end if
do idm=1,3
! transform to complex spherical harmonics
do ias=1,natmtot
is=idxis(ias)
call rtozfmt(nrmt(is),nrmti(is),rvfmt(:,ias,idm),zrhomt(:,ias))
end do
! solve Poisson's equation in the muffin-tin to find the A-field
call genzvclmt(nrmt,nrmti,nrmtmax,rlmt,wprmt,npmtmax,zrhomt,zvclmt)
zrhoir(:)=rvfir(:,idm)
! solve in the entire unit cell
call zpotcoul(nrmt,nrmti,npmt,npmti,nrmtmax,rlmt,ngridg,igfft,ngvec,gc,gclg, &
ngvec,jlgrmt,ylmg,sfacg,zrhoir,npmtmax,zvclmt,zvclir)
! convert muffin-tin A-field to real spherical harmonics
do ias=1,natmtot
is=idxis(ias)
call ztorfmt(nrmt(is),nrmti(is),zvclmt(:,ias),rvfmt(:,ias,idm))
end do
! store the real part of the interstitial A-field
rvfir(:,idm)=dble(zvclir(:))
end do
! compute the curl of A to obtain the dipole B-field
call curlrvf(rvfmt,rvfir,bdmt,bdir)
! add to the Kohn-Sham field
allocate(rfmt1(npcmtmax),rfmt2(npcmtmax))
do idm=1,3
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
! convert to coarse radial mesh
call rfmtftoc(nrc,nrci,bdmt(:,ias,idm),rfmt1)
! convert to spherical coordinates
call rbsht(nrc,nrci,rfmt1,rfmt2)
bsmt(1:npc,ias,idm)=bsmt(1:npc,ias,idm)+cb*rfmt2(1:npc)
end do
end do
do idm=1,3
bsir(:,idm)=bsir(:,idm)+cb*bdir(:,idm)*cfunir(:)
end do
deallocate(rvfmt,rvfir,rfmt1,rfmt2)
deallocate(zrhomt,zrhoir,zvclmt,zvclir)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/roteuler.f90 0000644 0000000 0000000 00000000132 13543334735 015010 x ustar 00 30 mtime=1569569245.129641625
30 atime=1569569241.369644027
30 ctime=1569569245.129641625
elk-6.3.2/src/roteuler.f90 0000644 0025044 0025044 00000005425 13543334735 017065 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: roteuler
! !INTERFACE:
subroutine roteuler(rot,ang)
! !INPUT/OUTPUT PARAMETERS:
! rot : rotation matrix (in,real(3,3))
! ang : Euler angles (alpha, beta, gamma) (out,real(3))
! !DESCRIPTION:
! Given a rotation matrix
! \begin{align*}
! &R(\alpha,\beta,\gamma)=\\
! &\left(\begin{matrix}
! \cos\gamma\cos\beta\cos\alpha-\sin\gamma\sin\alpha &
! \cos\gamma\cos\beta\sin\alpha+\sin\gamma\cos\alpha &
! -\cos\gamma\sin\beta \\
! -\sin\gamma\cos\beta\cos\alpha-\cos\gamma\sin\alpha &
! -\sin\gamma\cos\beta\sin\alpha+\cos\gamma\cos\alpha &
! \sin\gamma\sin\beta \\
! \sin\beta\cos\alpha &
! \sin\beta\sin\alpha &
! \cos\beta
! \end{matrix}\right),
! \end{align*}
! this routine determines the Euler angles, $(\alpha,\beta,\gamma)$. This
! corresponds to the so-called `$y$-convention', which involves the following
! successive rotations of the coordinate system:
! \begin{itemize}
! \item[1.]{The $x_1$-, $x_2$-, $x_3$-axes are rotated anticlockwise through
! an angle $\alpha$ about the $x_3$ axis}
! \item[2.]{The $x_1'$-, $x_2'$-, $x_3'$-axes are rotated anticlockwise
! through an angle $\beta$ about the $x_2'$ axis}
! \item[3.]{The $x_1''$-, $x_2''$-, $x_3''$-axes are rotated anticlockwise
! through an angle $\gamma$ about the $x_3''$ axis}
! \end{itemize}
! Note that the Euler angles are not necessarily unique for a given rotation
! matrix.
!
! !REVISION HISTORY:
! Created May 2003 (JKD)
! Fixed problem thanks to Frank Wagner, June 2013 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: rot(3,3)
real(8), intent(out) :: ang(3)
! local variables
real(8), parameter :: eps=1.d-8
real(8), parameter :: pi=3.1415926535897932385d0
real(8) det
! find the determinant
det=rot(1,2)*rot(2,3)*rot(3,1)-rot(1,3)*rot(2,2)*rot(3,1) &
+rot(1,3)*rot(2,1)*rot(3,2)-rot(1,1)*rot(2,3)*rot(3,2) &
+rot(1,1)*rot(2,2)*rot(3,3)-rot(1,2)*rot(2,1)*rot(3,3)
if ((det.lt.1.d0-eps).or.(det.gt.1.d0+eps)) then
write(*,*)
write(*,'("Error(roteuler): matrix improper or not unitary")')
write(*,'(" Determinant : ",G18.10)') det
write(*,*)
stop
end if
if ((abs(rot(3,1)).gt.eps).or.(abs(rot(3,2)).gt.eps)) then
ang(1)=atan2(rot(3,2),rot(3,1))
if (abs(rot(3,1)).gt.abs(rot(3,2))) then
ang(2)=atan2(rot(3,1)/cos(ang(1)),rot(3,3))
else
ang(2)=atan2(rot(3,2)/sin(ang(1)),rot(3,3))
end if
ang(3)=atan2(rot(2,3),-rot(1,3))
else
ang(1)=atan2(rot(1,2),rot(1,1))
if (rot(3,3).gt.0.d0) then
ang(2)=0.d0
ang(3)=0.d0
else
ang(2)=pi
ang(3)=pi
end if
end if
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/lopzflm.f90 0000644 0000000 0000000 00000000132 13543334735 014632 x ustar 00 30 mtime=1569569245.134641622
30 atime=1569569241.373644024
30 ctime=1569569245.134641622
elk-6.3.2/src/lopzflm.f90 0000644 0025044 0025044 00000003602 13543334735 016702 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: lopzflm
! !INTERFACE:
pure subroutine lopzflm(lmax,zflm,ld,zlflm)
! !INPUT/OUTPUT PARAMETERS:
! lmax : maximum angular momentum (in,integer)
! zflm : coefficients of input spherical harmonic expansion
! (in,complex((lmax+1)**2))
! ld : leading dimension (in,integer)
! zlflm : coefficients of output spherical harmonic expansion
! (out,complex(ld,3))
! !DESCRIPTION:
! Applies the angular momentum operator $\hat{\bf L}$ to a function expanded
! in terms of complex spherical harmonics. This makes use of the identities
! \begin{align*}
! (L_x+iL_y)Y_{lm}(\theta,\phi)&=\sqrt{(l-m)(l+m+1)}Y_{lm+1}(\theta,\phi)\\
! (L_x-iL_y)Y_{lm}(\theta,\phi)&=\sqrt{(l+m)(l-m+1)}Y_{lm-1}(\theta,\phi)\\
! L_zY_{lm}(\theta,\phi)&=mY_{lm}(\theta,\phi).
! \end{align*}
!
! !REVISION HISTORY:
! Created March 2004 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: lmax
complex(8), intent(in) :: zflm(*)
integer, intent(in) :: ld
complex(8), intent(out) :: zlflm(ld,3)
! local variables
integer l,m,lm
real(8) t1
complex(8) z1
lm=0
do l=0,lmax
do m=-l,l
lm=lm+1
if (m.eq.-l) then
zlflm(lm,1)=0.d0
zlflm(lm,2)=0.d0
end if
if (m.lt.l) then
t1=0.5d0*sqrt(dble((l-m)*(l+m+1)))
z1=t1*zflm(lm)
zlflm(lm+1,1)=z1
zlflm(lm+1,2)=cmplx(aimag(z1),-dble(z1),8)
end if
if (m.gt.-l) then
t1=0.5d0*sqrt(dble((l+m)*(l-m+1)))
z1=t1*zflm(lm)
zlflm(lm-1,1)=zlflm(lm-1,1)+z1
zlflm(lm-1,2)=zlflm(lm-1,2)+cmplx(-aimag(z1),dble(z1),8)
end if
if (m.ne.0) then
zlflm(lm,3)=dble(m)*zflm(lm)
else
zlflm(lm,3)=0.d0
end if
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/eveqnfvz.f90 0000644 0000000 0000000 00000000130 13543334735 015011 x ustar 00 29 mtime=1569569245.13864162
30 atime=1569569241.378644021
29 ctime=1569569245.13864162
elk-6.3.2/src/eveqnfvz.f90 0000644 0025044 0025044 00000003103 13543334735 017057 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.
subroutine eveqnfvz(nmatp,h,o,evalfv,evecfv)
use modmain
use modomp
implicit none
! arguments
integer, intent(in) :: nmatp
complex(8), intent(in) :: h(*),o(*)
real(8), intent(out) :: evalfv(nstfv)
complex(8), intent(out) :: evecfv(nmatmax,nstfv)
! local variables
integer i,m,nthd
integer lwork,info
real(8) vl,vu
real(8) ts0,ts1
! allocatable arrays
integer, allocatable :: iwork(:),ifail(:)
real(8), allocatable :: w(:),rwork(:)
complex(8), allocatable :: work(:)
call timesec(ts0)
allocate(iwork(5*nmatp),ifail(nmatp))
allocate(w(nmatp),rwork(7*nmatp))
lwork=2*nmatp
allocate(work(lwork))
! enable MKL parallelism
call holdthd(maxthdmkl,nthd)
call mkl_set_num_threads(nthd)
! diagonalise the matrix
call zhegvx(1,'V','I','U',nmatp,h,nmatp,o,nmatp,vl,vu,1,nstfv,evaltol,m,w, &
evecfv,nmatmax,work,lwork,rwork,iwork,ifail,info)
call freethd(nthd)
call mkl_set_num_threads(1)
if (info.ne.0) then
write(*,*)
write(*,'("Error(eveqnfvz): diagonalisation failed")')
write(*,'(" ZHEGVX returned INFO = ",I8)') info
if (info.gt.nmatp) then
i=info-nmatp
write(*,'(" The leading minor of the overlap matrix of order ",I8)') i
write(*,'(" is not positive definite")')
write(*,'(" Order of overlap matrix : ",I8)') nmatp
end if
write(*,*)
stop
end if
evalfv(1:nstfv)=w(1:nstfv)
deallocate(iwork,ifail,w,rwork,work)
call timesec(ts1)
!$OMP ATOMIC
timefv=timefv+ts1-ts0
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rhomag.f90 0000644 0000000 0000000 00000000132 13543334735 014424 x ustar 00 30 mtime=1569569245.142641617
30 atime=1569569241.382644019
30 ctime=1569569245.142641617
elk-6.3.2/src/rhomag.f90 0000644 0025044 0025044 00000006636 13543334735 016506 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.
subroutine rhomag
use modmain
use modmpi
use modomp
implicit none
! local variables
integer ik,ispn,idm
integer is,ias,n,nthd
! automatic arrays
integer(8) lock(natmtot)
! allocatable arrays
complex(8), allocatable :: apwalm(:,:,:,:,:),evecfv(:,:,:),evecsv(:,:)
! initialise the OpenMP locks
do ias=1,natmtot
call omp_init_lock(lock(ias))
end do
! set the charge density and magnetisation to zero
do ias=1,natmtot
is=idxis(ias)
rhomt(1:npcmt(is),ias)=0.d0
end do
rhoir(:)=0.d0
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
magmt(1:npcmt(is),ias,idm)=0.d0
end do
magir(:,idm)=0.d0
end do
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(apwalm,evecfv,evecsv,ispn) &
!$OMP NUM_THREADS(nthd)
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
allocate(evecfv(nmatmax,nstfv,nspnfv),evecsv(nstsv,nstsv))
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
! get the eigenvectors from file
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! find the matching coefficients
do ispn=1,nspnfv
call match(ngk(ispn,ik),vgkc(:,:,ispn,ik),gkc(:,ispn,ik), &
sfacgk(:,:,ispn,ik),apwalm(:,:,:,:,ispn))
end do
! add to the density and magnetisation
call rhomagk(ngk(:,ik),igkig(:,:,ik),lock,wkpt(ik),occsv(:,ik),apwalm, &
evecfv,evecsv)
end do
!$OMP END DO
deallocate(apwalm,evecfv,evecsv)
!$OMP END PARALLEL
call freethd(nthd)
! destroy the OpenMP locks
do ias=1,natmtot
call omp_destroy_lock(lock(ias))
end do
! convert muffin-tin density/magnetisation to spherical harmonics
call rhomagsh
call holdthd(2,nthd)
!$OMP PARALLEL SECTIONS DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP SECTION
! symmetrise the density
call symrf(nrcmt,nrcmti,npcmt,npmtmax,rhomt,rhoir)
! convert the density from a coarse to a fine radial mesh
call rfmtctof(rhomt)
!$OMP SECTION
! symmetrise the magnetisation
if (spinpol) call symrvf(.true.,ncmag,nrcmt,nrcmti,npcmt,npmtmax,magmt,magir)
!$OMP END PARALLEL SECTIONS
call freethd(nthd)
! convert the magnetisation from a coarse to a fine radial mesh
call holdthd(ndmag,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
do idm=1,ndmag
call rfmtctof(magmt(:,:,idm))
end do
!$OMP END PARALLEL DO
call freethd(nthd)
! add densities from each process and redistribute
if (np_mpi.gt.1) then
n=npmtmax*natmtot
call mpi_allreduce(mpi_in_place,rhomt,n,mpi_double_precision,mpi_sum,mpicom, &
ierror)
call mpi_allreduce(mpi_in_place,rhoir,ngtot,mpi_double_precision,mpi_sum, &
mpicom,ierror)
if (spinpol) then
n=n*ndmag
call mpi_allreduce(mpi_in_place,magmt,n,mpi_double_precision,mpi_sum, &
mpicom,ierror)
n=ngtot*ndmag
call mpi_allreduce(mpi_in_place,magir,n,mpi_double_precision,mpi_sum, &
mpicom,ierror)
end if
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
! add the core density and magnetisation to the total
call rhocore
call holdthd(2,nthd)
!$OMP PARALLEL SECTIONS DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP SECTION
! calculate the charges
call charge
! normalise the density
call rhonorm
!$OMP SECTION
! calculate the moments
if (spinpol) call moment
!$OMP END PARALLEL SECTIONS
call freethd(nthd)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmlaa.f90 0000644 0000000 0000000 00000000132 13543334735 014231 x ustar 00 30 mtime=1569569245.147641614
30 atime=1569569241.386644016
30 ctime=1569569245.147641614
elk-6.3.2/src/hmlaa.f90 0000644 0025044 0025044 00000004401 13543334735 016277 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,ias,ngp,apwalm,ld,h)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! thr : .true. if the matrix h is real valued (in,logical)
! 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) :: ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: h(*)
! local variables
integer is,lmo,io,jo,i
integer l1,l2,l3,m1,m2,m3
integer lm1,lm2,lm3
real(8) t0
complex(8) z1
! allocatable arrays
complex(8), allocatable :: a(:,:),b(:,:)
is=idxis(ias)
lmo=lmoapw(is)
allocate(a(lmo,ngp),b(lmo,ngp))
t0=0.5d0*rmt(is)**2
i=0
lm1=0
do l1=0,lmaxapw
do m1=-l1,l1
lm1=lm1+1
do io=1,apword(l1,is)
i=i+1
b(i,:)=0.d0
lm3=0
do l3=0,lmaxapw
do m3=-l3,l3
lm3=lm3+1
do jo=1,apword(l3,is)
z1=0.d0
do l2=0,lmaxo
if (mod(l1+l2+l3,2).eq.0) then
do m2=-l2,l2
lm2=idxlm(l2,m2)
z1=z1+gntyry(lm2,lm3,lm1)*haa(lm2,jo,l3,io,l1,ias)
end do
end if
end do
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
! kinetic surface contribution
do jo=1,apword(l1,is)
z1=t0*apwfr(nrmt(is),1,io,l1,ias)*apwdfr(jo,l1,ias)
call zaxpy(ngp,z1,apwalm(:,jo,lm1),1,b(i,1),lmo)
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)
deallocate(a,b)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/hmlalo.f90 0000644 0000000 0000000 00000000132 13543334735 014423 x ustar 00 30 mtime=1569569245.151641611
30 atime=1569569241.391644013
30 ctime=1569569245.151641611
elk-6.3.2/src/hmlalo.f90 0000644 0025044 0025044 00000002544 13543334735 016477 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 hmlalo(ias,ngp,apwalm,ld,h)
use modmain
implicit none
! arguments
integer, intent(in) :: ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: h(*)
! local variables
integer is,io,ilo
integer l1,l2,l3,m1,m2,m3
integer lm1,lm2,lm3,i,j,k
complex(8) z1
is=idxis(ias)
do ilo=1,nlorb(is)
l1=lorbl(ilo,is)
do m1=-l1,l1
lm1=idxlm(l1,m1)
j=ngp+idxlo(lm1,ilo,ias)
lm3=0
do l3=0,lmaxapw
do m3=-l3,l3
lm3=lm3+1
do io=1,apword(l3,is)
z1=0.d0
do l2=0,lmaxo
if (mod(l1+l2+l3,2).eq.0) then
do m2=-l2,l2
lm2=idxlm(l2,m2)
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
k=(j-1)*ld
do i=1,ngp
k=k+1
h(k)=h(k)+conjg(z1*apwalm(i,io,lm3))
end do
end if
end do
end do
end do
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gencore.f90 0000644 0000000 0000000 00000000131 13543334735 014570 x ustar 00 30 mtime=1569569245.156641608
29 atime=1569569241.39564401
30 ctime=1569569245.156641608
elk-6.3.2/src/gencore.f90 0000644 0025044 0025044 00000010561 13543334735 016643 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: gencore
! !INTERFACE:
subroutine gencore
! !USES:
use modmain
use modomp
! !DESCRIPTION:
! Computes the core radial wavefunctions, eigenvalues and densities. The
! radial Dirac equation is solved in the spherical part of the Kohn-Sham
! potential to which the atomic potential has been appended for
! $r>R_{\rm MT}$. In the case of spin-polarised calculations, and when
! {\tt spincore} is set to {\tt .true.}, the Dirac equation is solved in the
! spin-up and -down potentials created from the Kohn-Sham scalar potential and
! magnetic field magnitude, with the occupancy divided equally between up and
! down. The up and down densities determined in this way are added to both the
! scalar density and the magnetisation in the routine {\tt rhocore}. Note
! that this procedure is a simple, but inexact, approach to solving the radial
! Dirac equation in a magnetic field.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
! Added polarised cores, November 2009 (JKD)
!EOP
!BOC
implicit none
! local variables
integer ist,ispn,idm
integer is,ia,ja,ias,jas
integer nr,nri,nrs,ir,nthd
real(8) t1
! automatic arrays
logical done(natmmax)
real(8) vr(nrspmax),eval(nstspmax)
! allocatable arrays
real(8), allocatable :: br(:),fr(:,:)
if (spincore) allocate(br(nrmtmax),fr(nrmtmax,ndmag))
! loop over species and atoms
do is=1,nspecies
nr=nrmt(is)
nri=nrmti(is)
nrs=nrsp(is)
done(:)=.false.
do ia=1,natoms(is)
if (done(ia)) cycle
ias=idxas(ia,is)
! Kohn-Sham magnetic field for spin-polarised core
if (spincore) then
do idm=1,ndmag
call rfmtlm(1,nr,nri,bxcmt(:,ias,idm),fr(:,idm))
end do
if (ncmag) then
do ir=1,nr
br(ir)=sqrt(fr(ir,1)**2+fr(ir,2)**2+fr(ir,3)**2)*y00
end do
else
do ir=1,nr
br(ir)=abs(fr(ir,1))*y00
end do
end if
end if
! loop over spin channels
do ispn=1,nspncr
! use the spherical part of the crystal Kohn-Sham potential
call rfmtlm(1,nr,nri,vsmt(:,ias),vr)
vr(1:nr)=vr(1:nr)*y00
! spin-up and -down potentials for polarised core
if (spincore) then
if (ispn.eq.1) then
vr(1:nr)=vr(1:nr)+br(1:nr)
else
vr(1:nr)=vr(1:nr)-br(1:nr)
end if
end if
! append the Kohn-Sham potential from the atomic calculation for r > R_MT
t1=vr(nr)-vrsp(nr,is)
do ir=nr+1,nrs
vr(ir)=vrsp(ir,is)+t1
end do
rhocr(:,ias,ispn)=0.d0
call holdthd(nstsp(is),nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(t1,ir) SHARED(is) &
!$OMP NUM_THREADS(nthd)
do ist=1,nstsp(is)
if (spcore(ist,is)) then
! solve the Dirac equation
eval(ist)=evalcr(ist,ias)
call rdirac(solsc,nsp(ist,is),lsp(ist,is),ksp(ist,is),nrs,rsp(:,is), &
vr,eval(ist),rwfcr(:,1,ist,ias),rwfcr(:,2,ist,ias))
if (spincore) then
! use the spin-averaged eigenvalue for the polarised core
if (ispn.eq.1) then
evalcr(ist,ias)=eval(ist)
else
evalcr(ist,ias)=0.5d0*(evalcr(ist,ias)+eval(ist))
end if
t1=0.5d0*occcr(ist,ias)
else
evalcr(ist,ias)=eval(ist)
t1=occcr(ist,ias)
end if
! add to the core density
!$OMP CRITICAL(gencore_)
do ir=1,nr
rhocr(ir,ias,ispn)=rhocr(ir,ias,ispn) &
+t1*(rwfcr(ir,1,ist,ias)**2+rwfcr(ir,2,ist,ias)**2)
end do
!$OMP END CRITICAL(gencore_)
end if
end do
!$OMP END PARALLEL DO
call freethd(nthd)
do ir=1,nr
rhocr(ir,ias,ispn)=rhocr(ir,ias,ispn)*rlmt(ir,-2,is)*y00
end do
! end loop over spin channels
end do
done(ia)=.true.
! copy to equivalent atoms
do ja=1,natoms(is)
if ((.not.done(ja)).and.(eqatoms(ia,ja,is))) then
jas=idxas(ja,is)
do ist=1,nstsp(is)
if (spcore(ist,is)) then
evalcr(ist,jas)=evalcr(ist,ias)
rwfcr(1:nrs,:,ist,jas)=rwfcr(1:nrs,:,ist,ias)
end if
end do
rhocr(1:nr,jas,:)=rhocr(1:nr,ias,:)
done(ja)=.true.
end if
end do
! end loop over species and atoms
end do
end do
if (spincore) deallocate(br,fr)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/gentau.f90 0000644 0000000 0000000 00000000132 13543334735 014432 x ustar 00 30 mtime=1569569245.160641606
30 atime=1569569241.399644008
30 ctime=1569569245.160641606
elk-6.3.2/src/gentau.f90 0000644 0025044 0025044 00000005535 13543334735 016511 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.
subroutine gentau
use modmain
use modmpi
use modomp
implicit none
! local variables
integer ik,ispn,is,ias
integer np,npc,n,nthd
! allocatable arrays
real(8), allocatable :: rfmt(:,:),rfir(:)
real(8), allocatable :: rvfmt(:,:,:),rvfir(:,:)
! set the kinetic energy density to zero
taumt(:,:,:)=0.d0
tauir(:,:)=0.d0
! tau cannot be computed if wavefunctions do not exist
if (iscl.le.0) return
call holdthd(nkpt/np_mpi,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ik=1,nkpt
! distribute among MPI processes
if (mod(ik-1,np_mpi).ne.lp_mpi) cycle
call gentauk(ik)
end do
!$OMP END DO
!$OMP END PARALLEL
call freethd(nthd)
allocate(rfmt(npmtmax,natmtot))
! convert taumt to spherical harmonics
do ispn=1,nspinor
do ias=1,natmtot
is=idxis(ias)
call dcopy(npcmt(is),taumt(:,ias,ispn),1,rfmt,1)
call rfsht(nrcmt(is),nrcmti(is),rfmt,taumt(:,ias,ispn))
end do
end do
! symmetrise tau
if (spinpol) then
! spin-polarised case: convert to scalar-vector form
allocate(rfir(ngtot))
allocate(rvfmt(npmtmax,natmtot,ndmag))
allocate(rvfir(ngtot,ndmag))
do ias=1,natmtot
is=idxis(ias)
npc=npcmt(is)
rfmt(1:npc,ias)=taumt(1:npc,ias,1)+taumt(1:npc,ias,2)
rvfmt(1:npc,ias,1:ndmag-1)=0.d0
rvfmt(1:npc,ias,ndmag)=taumt(1:npc,ias,1)-taumt(1:npc,ias,2)
end do
rfir(:)=tauir(:,1)+tauir(:,2)
rvfir(:,1:ndmag-1)=0.d0
rvfir(:,ndmag)=tauir(:,1)-tauir(:,2)
call symrf(nrcmt,nrcmti,npcmt,npmtmax,rfmt,rfir)
call symrvf(.true.,ncmag,nrcmt,nrcmti,npcmt,npmtmax,rvfmt,rvfir)
do ias=1,natmtot
is=idxis(ias)
npc=npcmt(is)
taumt(1:npc,ias,1)=0.5d0*(rfmt(1:npc,ias)+rvfmt(1:npc,ias,ndmag))
taumt(1:npc,ias,2)=0.5d0*(rfmt(1:npc,ias)-rvfmt(1:npc,ias,ndmag))
end do
tauir(:,1)=0.5d0*(rfir(:)+rvfir(:,ndmag))
tauir(:,2)=0.5d0*(rfir(:)-rvfir(:,ndmag))
deallocate(rfir,rvfmt,rvfir)
else
! spin-unpolarised case
call symrf(nrcmt,nrcmti,npcmt,npmtmax,taumt,tauir)
end if
! convert taumt from a coarse to a fine radial mesh
do ispn=1,nspinor
call rfmtctof(taumt(:,:,ispn))
end do
! add tau from each process and redistribute
if (np_mpi.gt.1) then
n=npmtmax*natmtot*nspinor
call mpi_allreduce(mpi_in_place,taumt,n,mpi_double_precision,mpi_sum,mpicom, &
ierror)
n=ngtot*nspinor
call mpi_allreduce(mpi_in_place,tauir,n,mpi_double_precision,mpi_sum,mpicom, &
ierror)
end if
! generate the core kinetic energy density
call gentaucr
do ispn=1,nspinor
do ias=1,natmtot
is=idxis(ias)
np=npmt(is)
! add the core contribution
taumt(1:np,ias,ispn)=taumt(1:np,ias,ispn)+taucr(1:np,ias,ispn)
! zero tau on the inner part of the muffin-tin
taumt(1:npmti(is),ias,ispn)=0.d0
end do
end do
deallocate(rfmt)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gentauk.f90 0000644 0000000 0000000 00000000132 13543334735 014605 x ustar 00 30 mtime=1569569245.164641603
30 atime=1569569241.404644005
30 ctime=1569569245.164641603
elk-6.3.2/src/gentauk.f90 0000644 0025044 0025044 00000005617 13543334735 016665 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.
subroutine gentauk(ik)
use modmain
implicit none
! arguments
integer, intent(in) :: ik
! local variables
integer ispn,jspn,nst,ist,jst
integer is,ias,nrc,nrci
integer npc,igk,ifg,i
real(8) wo
complex(8) z1
! automatic arrays
integer idx(nstsv)
! allocatable arrays
complex(8), allocatable :: apwalm(:,:,:,:,:),evecfv(:,:),evecsv(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfgp(:,:,:)
complex(8), allocatable :: gzfmt(:,:),zfmt(:),zfft(:)
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
allocate(evecfv(nmatmax,nstfv),evecsv(nstsv,nstsv))
! find the matching coefficients
do ispn=1,nspnfv
call match(ngk(ispn,ik),vgkc(:,:,ispn,ik),gkc(:,ispn,ik), &
sfacgk(:,:,ispn,ik),apwalm(:,:,:,:,ispn))
end do
! get the eigenvectors from file
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! count and index the occupied states
nst=0
do ist=1,nstsv
if (abs(occsv(ist,ik)).lt.epsocc) cycle
nst=nst+1
idx(nst)=ist
end do
! calculate the second-variational wavefunctions for occupied states
allocate(wfmt(npcmtmax,natmtot,nspinor,nst),wfgp(ngkmax,nspinor,nst))
call genwfsv(.true.,.true.,nst,idx,ngridg,igfft,ngk(:,ik),igkig(:,:,ik), &
apwalm,evecfv,evecsv,wfmt,ngkmax,wfgp)
deallocate(apwalm,evecfv,evecsv)
!-------------------------!
! muffin-tin part !
!-------------------------!
allocate(gzfmt(npcmtmax,3),zfmt(npcmtmax))
do ist=1,nst
jst=idx(ist)
wo=0.5d0*wkpt(ik)*occsv(jst,ik)
do ispn=1,nspinor
do ias=1,natmtot
is=idxis(ias)
nrc=nrcmt(is)
nrci=nrcmti(is)
npc=npcmt(is)
! compute the gradient of the wavefunction
call gradzfmt(nrc,nrci,rlcmt(:,1,is),rlcmt(:,-1,is),wfmt(:,ias,ispn,ist),&
npcmtmax,gzfmt)
do i=1,3
! convert gradient to spherical coordinates
call zbsht(nrc,nrci,gzfmt(:,i),zfmt)
! add to total in muffin-tin
!$OMP CRITICAL(gentauk_1)
taumt(1:npc,ias,ispn)=taumt(1:npc,ias,ispn) &
+wo*(dble(zfmt(1:npc))**2+aimag(zfmt(1:npc))**2)
!$OMP END CRITICAL(gentauk_1)
end do
end do
end do
end do
deallocate(wfmt,gzfmt,zfmt)
!---------------------------!
! interstitial part !
!---------------------------!
allocate(zfft(ngtot))
do ist=1,nst
jst=idx(ist)
wo=0.5d0*wkpt(ik)*occsv(jst,ik)/omega
do ispn=1,nspinor
jspn=jspnfv(ispn)
do i=1,3
zfft(:)=0.d0
do igk=1,ngk(jspn,ik)
ifg=igfft(igkig(igk,jspn,ik))
z1=wfgp(igk,ispn,ist)
zfft(ifg)=vgkc(i,igk,jspn,ik)*cmplx(-aimag(z1),dble(z1),8)
end do
call zfftifc(3,ngridg,1,zfft)
!$OMP CRITICAL(gentauk_2)
tauir(:,ispn)=tauir(:,ispn)+wo*(dble(zfft(:))**2+aimag(zfft(:))**2)
!$OMP END CRITICAL(gentauk_2)
end do
end do
end do
deallocate(wfgp,zfft)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmlistl.f90 0000644 0000000 0000000 00000000126 13543334735 014626 x ustar 00 28 mtime=1569569245.1696416
30 atime=1569569241.408644002
28 ctime=1569569245.1696416
elk-6.3.2/src/hmlistl.f90 0000644 0025044 0025044 00000003260 13543334735 016673 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:
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(*)
! local variables
integer i1,i2,i3,j1,j2,j3
integer ig,i,j,k
real(8) v1,v2,v3,t1
do j=1,ngp
k=(j-1)*ld
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
k=k+1
ig=igpig(i)
i1=ivg(1,ig)-j1; i2=ivg(2,ig)-j2; i3=ivg(3,ig)-j3
ig=ivgig(i1,i2,i3)
t1=vgpc(1,i)*v1+vgpc(2,i)*v2+vgpc(3,i)*v3
h(k)=h(k)+vsig(ig)+t1*cfunig(ig)
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/olpistl.f90 0000644 0000000 0000000 00000000127 13543334735 014641 x ustar 00 30 mtime=1569569245.173641597
27 atime=1569569241.412644
30 ctime=1569569245.173641597
elk-6.3.2/src/olpistl.f90 0000644 0025044 0025044 00000002460 13543334735 016706 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:
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(*)
! local variables
integer i1,i2,i3,j1,j2,j3
integer ig,i,j,k
do j=1,ngp
k=(j-1)*ld
ig=igpig(j)
j1=ivg(1,ig); j2=ivg(2,ig); j3=ivg(3,ig)
do i=1,j
k=k+1
ig=igpig(i)
i1=ivg(1,ig)-j1; i2=ivg(2,ig)-j2; i3=ivg(3,ig)-j3
o(k)=o(k)+cfunig(ivgig(i1,i2,i3))
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/gengclg.f90 0000644 0000000 0000000 00000000132 13543334735 014555 x ustar 00 30 mtime=1569569245.177641595
30 atime=1569569241.417643996
30 ctime=1569569245.177641595
elk-6.3.2/src/gengclg.f90 0000644 0025044 0025044 00000000602 13543334735 016622 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
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/hmlrad.f90 0000644 0000000 0000000 00000000132 13543334735 014416 x ustar 00 30 mtime=1569569245.182641592
30 atime=1569569241.421643994
30 ctime=1569569245.182641592
elk-6.3.2/src/hmlrad.f90 0000644 0025044 0025044 00000014260 13543334735 016470 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2016 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: hmlrad
! !INTERFACE:
subroutine hmlrad
! !USES:
use modmain
use modomp
! !DESCRIPTION:
! Calculates the radial Hamiltonian integrals of the APW and local-orbital
! basis functions. In other words, for atom $\alpha$, it computes integrals of
! the form
! $$ h^{\alpha}_{qq';ll'l''m''}=\begin{cases}
! \int_0^{R_i}u^{\alpha}_{q;l}(r)H u^{\alpha}_{q';l'}(r)r^2dr & l''=0 \\
! \int_0^{R_i}u^{\alpha}_{q;l}(r)V^{\alpha}_{l''m''}(r)
! u^{\alpha}_{q';l'}(r)r^2dr & l''>0 \end{cases}, $$
! where $u^{\alpha}_{q;l}$ is the $q$th APW radial function for angular
! momentum $l$; $H$ is the Hamiltonian of the radial Schr\"{o}dinger equation;
! and $V^{\alpha}_{l''m''}$ is the muffin-tin Kohn-Sham potential. Similar
! integrals are calculated for APW-local-orbital and
! local-orbital-local-orbital contributions.
!
! !REVISION HISTORY:
! Created December 2003 (JKD)
! Updated for compressed muffin-tin functions, March 2016 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ias,nthd
integer nr,nri,iro
integer ir,npi,i
integer l1,l2,l3,m2,lm2
integer io,jo,ilo,jlo
real(8) t1
! allocatable arrays
real(8), allocatable :: fr(:)
! begin loops over atoms and species
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(fr,is,nr,nri,iro,npi) &
!$OMP PRIVATE(l1,l2,l3,io,jo,ir,t1) &
!$OMP PRIVATE(lm2,m2,i,ilo,jlo) &
!$OMP NUM_THREADS(nthd)
allocate(fr(nrmtmax))
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
iro=nri+1
npi=npmti(is)
!---------------------------!
! APW-APW integrals !
!---------------------------!
do l1=0,lmaxapw
do io=1,apword(l1,is)
do l3=0,lmaxapw
do jo=1,apword(l3,is)
if (l1.eq.l3) then
fr(1:nr)=apwfr(1:nr,1,io,l1,ias)*apwfr(1:nr,2,jo,l3,ias)
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
haa(1,jo,l3,io,l1,ias)=t1/y00
else
haa(1,jo,l3,io,l1,ias)=0.d0
end if
if (l1.ge.l3) then
lm2=1
do l2=1,lmaxi
do m2=-l2,l2
lm2=lm2+1
i=lm2
do ir=1,nri
t1=apwfr(ir,1,io,l1,ias)*apwfr(ir,1,jo,l3,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxi
end do
do ir=iro,nr
t1=apwfr(ir,1,io,l1,ias)*apwfr(ir,1,jo,l3,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxo
end do
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
haa(lm2,jo,l3,io,l1,ias)=t1
haa(lm2,io,l1,jo,l3,ias)=t1
end do
end do
do l2=lmaxi+1,lmaxo
do m2=-l2,l2
lm2=lm2+1
i=npi+lm2
do ir=iro,nr
t1=apwfr(ir,1,io,l1,ias)*apwfr(ir,1,jo,l3,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxo
end do
t1=dot_product(wrmt(iro:nr,is),fr(iro:nr))
haa(lm2,jo,l3,io,l1,ias)=t1
haa(lm2,io,l1,jo,l3,ias)=t1
end do
end do
end if
end do
end do
end do
end do
!-------------------------------------!
! local-orbital-APW integrals !
!-------------------------------------!
do ilo=1,nlorb(is)
l1=lorbl(ilo,is)
do l3=0,lmaxapw
do io=1,apword(l3,is)
if (l1.eq.l3) then
fr(1:nr)=lofr(1:nr,1,ilo,ias)*apwfr(1:nr,2,io,l3,ias)
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
hloa(1,io,l3,ilo,ias)=t1/y00
else
hloa(1,io,l3,ilo,ias)=0.d0
end if
lm2=1
do l2=1,lmaxi
do m2=-l2,l2
lm2=lm2+1
i=lm2
do ir=1,nri
t1=lofr(ir,1,ilo,ias)*apwfr(ir,1,io,l3,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxi
end do
do ir=nri+1,nr
t1=lofr(ir,1,ilo,ias)*apwfr(ir,1,io,l3,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxo
end do
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
hloa(lm2,io,l3,ilo,ias)=t1
end do
end do
do l2=lmaxi+1,lmaxo
do m2=-l2,l2
lm2=lm2+1
i=npi+lm2
do ir=iro,nr
t1=lofr(ir,1,ilo,ias)*apwfr(ir,1,io,l3,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxo
end do
t1=dot_product(wrmt(iro:nr,is),fr(iro:nr))
hloa(lm2,io,l3,ilo,ias)=t1
end do
end do
end do
end do
end do
!-----------------------------------------------!
! local-orbital-local-orbital integrals !
!-----------------------------------------------!
do ilo=1,nlorb(is)
l1=lorbl(ilo,is)
do jlo=1,nlorb(is)
l3=lorbl(jlo,is)
if (l1.eq.l3) then
fr(1:nr)=lofr(1:nr,1,ilo,ias)*lofr(1:nr,2,jlo,ias)
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
hlolo(1,jlo,ilo,ias)=t1/y00
else
hlolo(1,jlo,ilo,ias)=0.d0
end if
lm2=1
do l2=1,lmaxi
do m2=-l2,l2
lm2=lm2+1
i=lm2
do ir=1,nri
t1=lofr(ir,1,ilo,ias)*lofr(ir,1,jlo,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxi
end do
do ir=iro,nr
t1=lofr(ir,1,ilo,ias)*lofr(ir,1,jlo,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxo
end do
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
hlolo(lm2,jlo,ilo,ias)=t1
end do
end do
do l2=lmaxi+1,lmaxo
do m2=-l2,l2
lm2=lm2+1
i=npi+lm2
do ir=iro,nr
t1=lofr(ir,1,ilo,ias)*lofr(ir,1,jlo,ias)
fr(ir)=t1*vsmt(i,ias)
i=i+lmmaxo
end do
t1=dot_product(wrmt(iro:nr,is),fr(iro:nr))
hlolo(lm2,jlo,ilo,ias)=t1
end do
end do
end do
end do
! end loops over atoms and species
end do
!$OMP END DO
deallocate(fr)
!$OMP END PARALLEL
call freethd(nthd)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rhonorm.f90 0000644 0000000 0000000 00000000132 13543334735 014633 x ustar 00 30 mtime=1569569245.186641589
30 atime=1569569241.426643991
30 ctime=1569569245.186641589
elk-6.3.2/src/rhonorm.f90 0000644 0025044 0025044 00000003404 13543334735 016703 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: rhonorm
! !INTERFACE:
subroutine rhonorm
! !USES:
use modmain
! !DESCRIPTION:
! Loss of precision of the calculated total charge can result because the
! muffin-tin density is computed on a set of $(\theta,\phi)$ points and then
! transformed to a spherical harmonic representation. This routine adds a
! constant to the density so that the total charge is correct. If the error in
! total charge exceeds a certain tolerance then a warning is issued.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
! Changed from rescaling to adding, September 2006 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ia,ias
integer nr,nri,ir,i
real(8) t1,t2
if (.not.trhonorm) return
! check error in total charge
t1=chgcalc/chgtot-1.d0
if (abs(t1).gt.epschg) then
write(*,*)
write(*,'("Warning(rhonorm): total charge density incorrect for s.c. &
&loop ",I5)') iscl
write(*,'(" Calculated : ",G18.10)') chgcalc
write(*,'(" Required : ",G18.10)') chgtot
end if
! error in average density
t1=(chgtot-chgcalc)/omega
! add the constant difference to the density
t2=t1/y00
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
i=1
do ir=1,nri
rhomt(i,ias)=rhomt(i,ias)+t2
i=i+lmmaxi
end do
do ir=nri+1,nr
rhomt(i,ias)=rhomt(i,ias)+t2
i=i+lmmaxo
end do
end do
rhoir(:)=rhoir(:)+t1
! add the difference to the charges
do is=1,nspecies
t2=t1*(4.d0*pi/3.d0)*rmt(is)**3
do ia=1,natoms(is)
ias=idxas(ia,is)
chgmt(ias)=chgmt(ias)+t2
chgmttot=chgmttot+t2
end do
end do
chgir=chgtot-chgmttot
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rfmtsm.f90 0000644 0000000 0000000 00000000132 13543334735 014457 x ustar 00 30 mtime=1569569245.191641586
30 atime=1569569241.430643988
30 ctime=1569569245.191641586
elk-6.3.2/src/rfmtsm.f90 0000644 0025044 0025044 00000001725 13543334735 016533 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 rfmtsm(m,nr,nri,rfmt)
use modmain
implicit none
! arguments
integer, intent(in) :: m,nr,nri
real(8), intent(inout) :: rfmt(*)
! local variables
integer nro,iro,ir
integer lm,npi,i
! automatic arrays
real(8) fr(nr)
if (m.le.0) return
nro=nr-nri
iro=nri+1
npi=lmmaxi*nri
do lm=1,lmmaxi
i=lm
do ir=1,nri
fr(ir)=rfmt(i)
i=i+lmmaxi
end do
do ir=iro,nr
fr(ir)=rfmt(i)
i=i+lmmaxo
end do
call fsmooth(m,nr,fr)
i=lm
do ir=1,nri
rfmt(i)=fr(ir)
i=i+lmmaxi
end do
do ir=iro,nr
rfmt(i)=fr(ir)
i=i+lmmaxo
end do
end do
do lm=lmmaxi+1,lmmaxo
i=npi+lm
do ir=iro,nr
fr(ir)=rfmt(i)
i=i+lmmaxo
end do
call fsmooth(m,nro,fr(iro))
i=npi+lm
do ir=iro,nr
rfmt(i)=fr(ir)
i=i+lmmaxo
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/olplolo.f90 0000644 0000000 0000000 00000000132 13543334735 014627 x ustar 00 30 mtime=1569569245.195641583
30 atime=1569569241.434643985
30 ctime=1569569245.195641583
elk-6.3.2/src/olplolo.f90 0000644 0025044 0025044 00000001356 13543334735 016703 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 olplolo(ias,ngp,ld,o)
use modmain
implicit none
! arguments
integer, intent(in) :: ias,ngp,ld
complex(8), intent(inout) :: o(ld,*)
! local variables
integer is,ilo,jlo
integer l,m,lm,i,j
is=idxis(ias)
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do jlo=1,nlorb(is)
if (lorbl(jlo,is).eq.l) then
do m=-l,l
lm=idxlm(l,m)
i=ngp+idxlo(lm,ilo,ias)
j=ngp+idxlo(lm,jlo,ias)
if (i.le.j) then
o(i,j)=o(i,j)+ololo(ilo,jlo,ias)
end if
end do
end if
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/genshtmat.f90 0000644 0000000 0000000 00000000132 13543334735 015141 x ustar 00 30 mtime=1569569245.199641581
30 atime=1569569241.438643983
30 ctime=1569569245.199641581
elk-6.3.2/src/genshtmat.f90 0000644 0025044 0025044 00000006226 13543334735 017216 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: genshtmat
! !INTERFACE:
subroutine genshtmat
! !USES:
use modmain
! !DESCRIPTION:
! Generates the forward and backward spherical harmonic transformation (SHT)
! matrices using the spherical covering set produced by the routine
! {\tt sphcover}. These matrices are used to transform a function between its
! $(l,m)$-expansion coefficients and its values at the $(\theta,\phi)$ points
! on the sphere.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer itp
real(8) v(3)
! automatic arrays
real(8) tp(2,lmmaxo),vtp(3,lmmaxo),rlm(lmmaxo)
complex(8) ylm(lmmaxo)
!--------------------------------!
! SHT matrices for lmaxo !
!--------------------------------!
! allocate real SHT matrices
if (allocated(rbshto)) deallocate(rbshto)
allocate(rbshto(lmmaxo,lmmaxo))
if (allocated(rfshto)) deallocate(rfshto)
allocate(rfshto(lmmaxo,lmmaxo))
! allocate complex SHT matrices
if (allocated(zbshto)) deallocate(zbshto)
allocate(zbshto(lmmaxo,lmmaxo))
if (allocated(zfshto)) deallocate(zfshto)
allocate(zfshto(lmmaxo,lmmaxo))
! generate spherical covering set
call sphcover(lmmaxo,tp)
! convert (theta, phi) angles to vectors
do itp=1,lmmaxo
call sctovec(tp(:,itp),vtp(:,itp))
end do
! rotate the spherical covering set if required
if (trotsht) then
do itp=1,lmmaxo
v(:)=vtp(:,itp)
call r3mv(rotsht,v,vtp(:,itp))
end do
end if
! generate real and complex spherical harmonics and set the backward SHT arrays
do itp=1,lmmaxo
call genrlmv(lmaxo,vtp(:,itp),rlm)
rbshto(itp,1:lmmaxo)=rlm(1:lmmaxo)
call genylmv(lmaxo,vtp(:,itp),ylm)
zbshto(itp,1:lmmaxo)=ylm(1:lmmaxo)
end do
! find the forward SHT arrays
! real
rfshto(:,:)=rbshto(:,:)
call rminv(lmmaxo,rfshto)
! complex
zfshto(:,:)=zbshto(:,:)
call zminv(lmmaxo,zfshto)
!--------------------------------!
! SHT matrices for lmaxi !
!--------------------------------!
! allocate real SHT matrices
if (allocated(rbshti)) deallocate(rbshti)
allocate(rbshti(lmmaxi,lmmaxi))
if (allocated(rfshti)) deallocate(rfshti)
allocate(rfshti(lmmaxi,lmmaxi))
! allocate complex SHT matrices
if (allocated(zbshti)) deallocate(zbshti)
allocate(zbshti(lmmaxi,lmmaxi))
if (allocated(zfshti)) deallocate(zfshti)
allocate(zfshti(lmmaxi,lmmaxi))
! generate spherical covering set for lmaxi
call sphcover(lmmaxi,tp)
! convert (theta, phi) angles to vectors
do itp=1,lmmaxi
call sctovec(tp(:,itp),vtp(:,itp))
end do
! rotate the spherical covering set if required
if (trotsht) then
do itp=1,lmmaxi
v(:)=vtp(:,itp)
call r3mv(rotsht,v,vtp(:,itp))
end do
end if
! generate real and complex spherical harmonics and set the backward SHT arrays
do itp=1,lmmaxi
call genrlmv(lmaxi,vtp(:,itp),rlm)
rbshti(itp,1:lmmaxi)=rlm(1:lmmaxi)
call genylmv(lmaxi,vtp(:,itp),ylm)
zbshti(itp,1:lmmaxi)=ylm(1:lmmaxi)
end do
! find the forward SHT arrays
! real
rfshti(:,:)=rbshti(:,:)
call rminv(lmmaxi,rfshti)
! complex
zfshti(:,:)=zbshti(:,:)
call zminv(lmmaxi,zfshti)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/allatoms.f90 0000644 0000000 0000000 00000000131 13543334735 014762 x ustar 00 30 mtime=1569569245.204641577
29 atime=1569569241.44364398
30 ctime=1569569245.204641577
elk-6.3.2/src/allatoms.f90 0000644 0025044 0025044 00000003571 13543334735 017040 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: allatoms
! !INTERFACE:
subroutine allatoms
! !USES:
use modmain
use modxcifc
use modomp
! !DESCRIPTION:
! Solves the Kohn-Sham-Dirac equations for each atom type in the solid and
! finds the self-consistent radial wavefunctions, eigenvalues, charge
! densities and potentials. The atomic densities can then be used to
! initialise the crystal densities, and the atomic self-consistent potentials
! can be appended to the muffin-tin potentials to solve for the core states.
! Note that, irrespective of the value of {\tt xctype}, exchange-correlation
! functional type 3 is used. See also {\tt atoms}, {\tt rhoinit},
! {\tt gencore} and {\tt modxcifc}.
!
! !REVISION HISTORY:
! Created September 2002 (JKD)
! Modified for GGA, June 2007 (JKD)
!EOP
!BOC
implicit none
logical hybrid_
integer xcspin_,xcgrad_
integer is,nthd
real(8) hybridc_
character(512) xcdescr_
! allocatable arrays
real(8), allocatable :: rwf(:,:,:)
! allocate global species charge density and potential arrays
if (allocated(rhosp)) deallocate(rhosp)
allocate(rhosp(nrspmax,nspecies))
if (allocated(vrsp)) deallocate(vrsp)
allocate(vrsp(nrspmax,nspecies))
! get the exchange-correlation functional data
call getxcdata(xctsp,xcdescr_,xcspin_,xcgrad_,hybrid_,hybridc_)
call holdthd(nspecies,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(rwf) &
!$OMP NUM_THREADS(nthd)
allocate(rwf(nrspmax,2,nstspmax))
!$OMP DO
do is=1,nspecies
call atom(solsc,ptnucl,spzn(is),nstsp(is),nsp(:,is),lsp(:,is),ksp(:,is), &
occsp(:,is),xctsp,xcgrad_,nrsp(is),rsp(:,is),evalsp(:,is),rhosp(:,is), &
vrsp(:,is),rwf)
end do
!$OMP END DO
deallocate(rwf)
!$OMP END PARALLEL
call freethd(nthd)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rtozflm.f90 0000644 0000000 0000000 00000000132 13543334735 014644 x ustar 00 30 mtime=1569569245.208641575
30 atime=1569569241.447643977
30 ctime=1569569245.208641575
elk-6.3.2/src/rtozflm.f90 0000644 0025044 0025044 00000003275 13543334735 016722 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: rtozflm
! !INTERFACE:
pure subroutine rtozflm(lmax,rflm,zflm)
! !INPUT/OUTPUT PARAMETERS:
! lmax : maximum angular momentum (in,integer)
! rflm : coefficients of real spherical harmonic expansion
! (in,real((lmax+1)**2)))
! zflm : coefficients of complex spherical harmonic expansion
! (out,complex((lmax+1)**2)))
! !DESCRIPTION:
! Converts a real function, $r_{lm}$, expanded in terms of real spherical
! harmonics into a complex spherical harmonic expansion, $z_{lm}$:
! $$ z_{lm}=\begin{cases} \frac{1}{\sqrt{2}}(r_{lm}+i(-1)^mr_{l-m}) & m>0 \\
! \frac{1}{\sqrt{2}}((-1)^mr_{l-m}-ir_{lm}) & m<0 \\
! r_{lm} & m=0 \end{cases}\;. $$
! See routine {\tt genrlm}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: lmax
real(8), intent(in) :: rflm(*)
complex(8), intent(out) :: zflm(*)
! local variables
integer l,m,lm1,lm2
! real constant 1/sqrt(2)
real(8), parameter :: c1=0.7071067811865475244d0
lm1=0
do l=0,lmax
lm2=lm1+2*(l+1)
do m=-l,-1
lm1=lm1+1
lm2=lm2-1
if (mod(m,2).ne.0) then
zflm(lm1)=c1*cmplx(-rflm(lm2),-rflm(lm1),8)
else
zflm(lm1)=c1*cmplx(rflm(lm2),-rflm(lm1),8)
end if
end do
lm1=lm1+1
lm2=lm2-1
zflm(lm1)=rflm(lm1)
do m=1,l
lm1=lm1+1
lm2=lm2-1
if (mod(m,2).ne.0) then
zflm(lm1)=c1*cmplx(rflm(lm1),-rflm(lm2),8)
else
zflm(lm1)=c1*cmplx(rflm(lm1),rflm(lm2),8)
end if
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rtozfmt.f90 0000644 0000000 0000000 00000000132 13543334735 014654 x ustar 00 30 mtime=1569569245.212641572
30 atime=1569569241.452643974
30 ctime=1569569245.212641572
elk-6.3.2/src/rtozfmt.f90 0000644 0025044 0025044 00000001063 13543334735 016723 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 rtozfmt(nr,nri,rfmt,zfmt)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: rfmt(*)
complex(8), intent(out) :: zfmt(*)
! local variables
integer ir,i
i=1
do ir=1,nri
call rtozflm(lmaxi,rfmt(i),zfmt(i))
i=i+lmmaxi
end do
do ir=nri+1,nr
call rtozflm(lmaxo,rfmt(i),zfmt(i))
i=i+lmmaxo
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gauntyry.f90 0000644 0000000 0000000 00000000130 13543334735 015027 x ustar 00 29 mtime=1569569245.21664157
30 atime=1569569241.456643971
29 ctime=1569569245.21664157
elk-6.3.2/src/gauntyry.f90 0000644 0025044 0025044 00000003034 13543334735 017100 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: gauntyry
! !INTERFACE:
complex(8) function gauntyry(l1,l2,l3,m1,m2,m3)
! !INPUT/OUTPUT PARAMETERS:
! l1, l2, l3 : angular momentum quantum numbers (in,integer)
! m1, m2, m3 : magnetic quantum numbers (in,integer)
! !DESCRIPTION:
! Returns the complex Gaunt-like coefficient given by
! $\langle Y^{l_1}_{m_1}|R^{l_2}_{m_2}|Y^{l_3}_{m_3}\rangle$, where $Y_{lm}$
! and $R_{lm}$ are the complex and real spherical harmonics, respectively.
! Suitable for $l_i$ less than 50. See routine {\tt genrlm}.
!
! !REVISION HISTORY:
! Created November 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: l1,l2,l3
integer, intent(in) :: m1,m2,m3
! local variables
! real constant sqrt(2)/2
real(8), parameter :: c1=0.7071067811865475244d0
real(8) t1
! external functions
real(8) gaunt
external gaunt
if (m2.gt.0) then
if (mod(m2,2).eq.0) then
t1=c1*(gaunt(l1,l2,l3,m1,m2,m3)+gaunt(l1,l2,l3,m1,-m2,m3))
else
t1=c1*(gaunt(l1,l2,l3,m1,m2,m3)-gaunt(l1,l2,l3,m1,-m2,m3))
end if
gauntyry=cmplx(t1,0.d0,8)
else if (m2.lt.0) then
if (mod(m2,2).eq.0) then
t1=c1*(gaunt(l1,l2,l3,m1,m2,m3)-gaunt(l1,l2,l3,m1,-m2,m3))
else
t1=c1*(gaunt(l1,l2,l3,m1,m2,m3)+gaunt(l1,l2,l3,m1,-m2,m3))
end if
gauntyry=cmplx(0.d0,-t1,8)
else
gauntyry=cmplx(gaunt(l1,l2,l3,m1,m2,m3),0.d0,8)
end if
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/fderiv.f90 0000644 0000000 0000000 00000000132 13543334735 014426 x ustar 00 30 mtime=1569569245.221641567
30 atime=1569569241.460643969
30 ctime=1569569245.221641567
elk-6.3.2/src/fderiv.f90 0000644 0025044 0025044 00000003270 13543334735 016477 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: fderiv
! !INTERFACE:
subroutine fderiv(m,n,x,f,g)
! !INPUT/OUTPUT PARAMETERS:
! m : order of derivative (in,integer)
! n : number of points (in,integer)
! x : abscissa array (in,real(n))
! f : function array (in,real(n))
! g : (anti-)derivative of f (out,real(n))
! !DESCRIPTION:
! Given function $f$ defined on a set of points $x_i$ then if $m\ge 0$ this
! routine computes the $m$th derivative of $f$ at each point. If $m=-1$ the
! anti-derivative of $f$ given by
! $$ g(x_i)=\int_{x_1}^{x_i} f(x)\,dx $$
! is calculated. Both derivatives and integrals are computed by first fitting
! the function to a clamped cubic spline.
!
! !REVISION HISTORY:
! Created May 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: m,n
real(8), intent(in) :: x(n),f(n)
real(8), intent(out) :: g(n)
! local variables
integer i
real(8) sum,dx
! automatic arrays
real(8) cf(3,n)
if (n.le.0) then
write(*,*)
write(*,'("Error(fderiv): invalid number of points : ",I8)') n
write(*,*)
stop
end if
! high accuracy integration/differentiation from spline interpolation
call spline(n,x,f,cf)
select case(m)
case(:-1)
sum=0.d0
g(1)=0.d0
do i=1,n-1
dx=x(i+1)-x(i)
sum=sum+dx*(f(i) &
+dx*(0.5d0*cf(1,i) &
+dx*(0.3333333333333333333d0*cf(2,i) &
+dx*0.25d0*cf(3,i))))
g(i+1)=sum
end do
case(1)
g(:)=cf(1,:)
case(2)
g(:)=2.d0*cf(2,:)
case(3)
g(:)=6.d0*cf(3,:)
case(4:)
g(:)=0.d0
end select
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/moment.f90 0000644 0000000 0000000 00000000132 13543334735 014446 x ustar 00 30 mtime=1569569245.225641564
30 atime=1569569241.465643966
30 ctime=1569569245.225641564
elk-6.3.2/src/moment.f90 0000644 0025044 0025044 00000002775 13543334735 016530 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,nr,nri
real(8) t1
! automatic arrays
real(8) fr(nrmtmax)
if (.not.spinpol) then
mommt(:,:)=0.d0
mommttot(:)=0.d0
momir(:)=0.d0
momtot(:)=0.d0
return
end if
! find the muffin-tin moments
mommttot(:)=0.d0
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
! extract the l=m=0 component from the muffin-tin magnetisation
call rfmtlm(1,nr,nri,magmt(:,ias,idm),fr)
! integrate to the muffin-tin radius
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
mommt(idm,ias)=fourpi*y00*t1
mommttot(idm)=mommttot(idm)+mommt(idm,ias)
end do
end do
! find the interstitial moments
do idm=1,ndmag
t1=dot_product(magir(:,idm),cfunir(:))
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)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/sctovec.f90 0000644 0000000 0000000 00000000132 13543334735 014615 x ustar 00 30 mtime=1569569245.229641562
30 atime=1569569241.469643963
30 ctime=1569569245.229641562
elk-6.3.2/src/sctovec.f90 0000644 0025044 0025044 00000000644 13543334735 016670 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.
subroutine sctovec(tp,v)
implicit none
! arguments
real(8), intent(in) :: tp(2)
real(8), intent(out) :: v(3)
! local variables
real(8) t1
t1=sin(tp(1))
v(1)=t1*cos(tp(2))
v(2)=t1*sin(tp(2))
v(3)=cos(tp(1))
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/match.f90 0000644 0000000 0000000 00000000132 13543334735 014243 x ustar 00 30 mtime=1569569245.234641558
30 atime=1569569241.473643961
30 ctime=1569569245.234641558
elk-6.3.2/src/match.f90 0000644 0025044 0025044 00000012276 13543334735 016322 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.
!BOP
! !ROUTINE: match
! !INTERFACE:
subroutine match(ngp,vgpc,gpc,sfacgp,apwalm)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! ngp : number of G+p-vectors (in,integer)
! vgpc : G+p-vectors in Cartesian coordinates (in,real(3,ngkmax))
! gpc : length of G+p-vectors (in,real(ngkmax))
! sfacgp : structure factors of G+p-vectors (in,complex(ngkmax,natmtot))
! apwalm : APW matching coefficients
! (out,complex(ngkmax,apwordmax,lmmaxapw,natmtot))
! !DESCRIPTION:
! Computes the $({\bf G+p})$-dependent matching coefficients for the APW basis
! functions. Inside muffin-tin $\alpha$, the APW functions are given by
! $$ \phi^{\alpha}_{\bf G+p}({\bf r})=\sum_{l=0}^{l_{\rm max}}
! \sum_{m=-l}^{l}\sum_{j=1}^{M^{\alpha}_l}A^{\alpha}_{jlm}({\bf G+p})
! u^{\alpha}_{jl}(r)Y_{lm}(\hat{{\bf r}}), $$
! where $A^{\alpha}_{jlm}({\bf G+p})$ is the matching coefficient,
! $M^{\alpha}_l$ is the order of the APW and $u^{\alpha}_{jl}$ is the radial
! function. In the interstitial region, an APW function is a plane wave,
! $\exp(i({\bf G+p})\cdot{\bf r})/\sqrt{\Omega}$, where $\Omega$ is the unit
! cell volume. Ensuring continuity up to the $(M^{\alpha}_l-1)$th derivative
! across the muffin-tin boundary therefore requires that the matching
! coefficients satisfy
! $$ \sum_{j=1}^{M^{\alpha}_l}D_{ij}A^{\alpha}_{jlm}({\bf G+p})=b_i\;, $$
! where
! $$ D_{ij}=\left.\frac{d^{i-1}u^{\alpha}_{jl}(r)}{dr^{i-1}}
! \right|_{r=R_{\alpha}} $$
! and
! $$ b_i=\frac{4\pi i^l}{\sqrt{\Omega}}|{\bf G+p}|^{i-1}j^{(i-1)}_l
! (|{\bf G+p}|R_{\alpha})\exp(i({\bf G+p})\cdot{\bf r}_{\alpha})Y^*_{lm}
! (\widehat{{\bf G+p}}), $$
! with ${\bf r}_{\alpha}$ the atomic position and $R_{\alpha}$ the muffin-tin
! radius. See routine {\tt wavefmt}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
! Fixed documentation, June 2006 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ngp
real(8), intent(in) :: vgpc(3,ngkmax),gpc(ngkmax)
complex(8), intent(in) :: sfacgp(ngkmax,natmtot)
complex(8), intent(out) :: apwalm(ngkmax,apwordmax,lmmaxapw,natmtot)
! local variables
integer is,ia,ias,omax
integer l,m,lm,io,jo,i
integer nr,ir,igp,info
real(8) t0,t1
complex(8) z1,z2,z3
! automatic arrays
integer ipiv(apwordmax)
complex(8) a(apwordmax,apwordmax)
! allocatable arrays
real(8), allocatable :: djl(:,:,:)
complex(8), allocatable :: ylmgp(:,:),b(:,:)
! external functions
real(8) polynm
external polynm
allocate(djl(0:lmaxapw,apwordmax,ngp),ylmgp(lmmaxapw,ngp))
if (apwordmax.gt.1) allocate(b(apwordmax,ngp*(2*lmaxapw+1)))
! compute the spherical harmonics of the G+p-vectors
do igp=1,ngp
call genylmv(lmaxapw,vgpc(:,igp),ylmgp(:,igp))
end do
t0=fourpi/sqrt(omega)
! loop over species
do is=1,nspecies
nr=nrmt(is)
! maximum APW order for this species
omax=maxval(apword(1:lmaxapw,is))
! special case of omax=1
if (omax.eq.1) then
do igp=1,ngp
t1=gpc(igp)*rmt(is)
call sbessel(lmaxapw,t1,djl(:,1,igp))
end do
do ia=1,natoms(is)
ias=idxas(ia,is)
do l=0,lmaxapw
z1=(t0/apwfr(nr,1,1,l,ias))*zil(l)
do igp=1,ngp
z2=djl(l,1,igp)*z1*sfacgp(igp,ias)
do m=-l,l
lm=idxlm(l,m)
apwalm(igp,1,lm,ias)=z2*conjg(ylmgp(lm,igp))
end do
end do
end do
end do
cycle
end if
! starting point on radial mesh for fitting polynomial of order npapw
ir=nr-npapw+1
! evaluate the spherical Bessel function derivatives for all G+p-vectors
do igp=1,ngp
t1=gpc(igp)*rmt(is)
do io=1,omax
call sbesseldm(io-1,lmaxapw,t1,djl(:,io,igp))
end do
t1=1.d0
do io=2,omax
t1=t1*gpc(igp)
djl(:,io,igp)=t1*djl(:,io,igp)
end do
end do
! loop over atoms
do ia=1,natoms(is)
ias=idxas(ia,is)
! begin loop over l
do l=0,lmaxapw
z1=t0*zil(l)
! set up matrix of derivatives
do jo=1,apword(l,is)
do io=1,apword(l,is)
a(io,jo)=polynm(io-1,npapw,rsp(ir,is),apwfr(ir,1,jo,l,ias),rmt(is))
end do
end do
! set up target vectors
i=0
do igp=1,ngp
z2=z1*sfacgp(igp,ias)
do m=-l,l
lm=idxlm(l,m)
i=i+1
z3=z2*conjg(ylmgp(lm,igp))
do io=1,apword(l,is)
b(io,i)=djl(l,io,igp)*z3
end do
end do
end do
! solve the general complex linear systems
call zgesv(apword(l,is),i,a,apwordmax,ipiv,b,apwordmax,info)
if (info.ne.0) then
write(*,*)
write(*,'("Error(match): could not find APW matching coefficients")')
write(*,'(" for species ",I4," and atom ",I4)') is,ia
write(*,'(" ZGESV returned INFO = ",I8)') info
write(*,*)
stop
end if
i=0
do igp=1,ngp
do m=-l,l
lm=idxlm(l,m)
i=i+1
do io=1,apword(l,is)
apwalm(igp,io,lm,ias)=b(io,i)
end do
end do
end do
! end loop over l
end do
! end loops over atoms and species
end do
end do
deallocate(djl,ylmgp)
if (apwordmax.gt.1) deallocate(b)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/writeinfo.f90 0000644 0000000 0000000 00000000132 13543334735 015155 x ustar 00 30 mtime=1569569245.239641555
30 atime=1569569241.478643957
30 ctime=1569569245.239641555
elk-6.3.2/src/writeinfo.f90 0000644 0025044 0025044 00000033141 13543334735 017226 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.
!BOP
! !ROUTINE: writeinfo
! !INTERFACE:
subroutine writeinfo(fnum)
! !USES:
use modmain
use moddftu
use modrdm
use modxcifc
use modmpi
! !INPUT/OUTPUT PARAMETERS:
! fnum : unit specifier for INFO.OUT file (in,integer)
! !DESCRIPTION:
! Outputs basic information about the run to the file {\tt INFO.OUT}. Does not
! close the file afterwards.
!
! !REVISION HISTORY:
! Created January 2003 (JKD)
! Updated with DFT+U quantities July 2009 (FC)
!EOP
!BOC
implicit none
! arguments
integer fnum
! local variables
integer i,is,ia,k,l
character(10) dat,tim
write(fnum,'("+----------------------------+")')
write(fnum,'("| Elk version ",I1.1,".",I1.1,".",I2.2," started |")') version
write(fnum,'("+----------------------------+")')
call date_and_time(date=dat,time=tim)
write(fnum,*)
write(fnum,'("Date (YYYY-MM-DD) : ",A4,"-",A2,"-",A2)') dat(1:4),dat(5:6), &
dat(7:8)
write(fnum,'("Time (hh:mm:ss) : ",A2,":",A2,":",A2)') tim(1:2),tim(3:4), &
tim(5:6)
if (np_mpi.gt.1) then
write(fnum,*)
write(fnum,'("Using MPI, number of processes : ",I8)') np_mpi
end if
if (notelns.gt.0) then
write(fnum,*)
write(fnum,'("Notes :")')
do i=1,notelns
write(fnum,'(A)') trim(notes(i))
end do
end if
write(fnum,*)
write(fnum,'("All units are atomic (Hartree, Bohr, etc.)")')
write(fnum,*)
select case(task)
case(0,1,28,29,200,201,350,351,360,440)
if (trdstate) then
write(fnum,'("+------------------------------------------+")')
write(fnum,'("| Ground-state run resuming from STATE.OUT |")')
write(fnum,'("+------------------------------------------+")')
else
write(fnum,'("+-------------------------------------------------+")')
write(fnum,'("| Ground-state run starting from atomic densities |")')
write(fnum,'("+-------------------------------------------------+")')
end if
case(2,3)
if (trdstate) then
write(fnum,'("+---------------------------------------------------+")')
write(fnum,'("| Geometry optimisation run resuming from STATE.OUT |")')
write(fnum,'("+---------------------------------------------------+")')
else
write(fnum,'("+------------------------------------------------------+")')
write(fnum,'("| Geometry optimisation starting from atomic densities |")')
write(fnum,'("+------------------------------------------------------+")')
end if
case(5)
write(fnum,'("+-------------------------------+")')
write(fnum,'("| Ground-state Hartree-Fock run |")')
write(fnum,'("+-------------------------------+")')
case(300)
write(fnum,'("+----------------------------------------------+")')
write(fnum,'("| Reduced density matrix functional theory run |")')
write(fnum,'("+----------------------------------------------+")')
case default
write(*,*)
write(*,'("Error(writeinfo): task not defined : ",I8)') task
write(*,*)
stop
end select
write(fnum,*)
write(fnum,'("Lattice vectors :")')
write(fnum,'(3G18.10)') avec(1,1),avec(2,1),avec(3,1)
write(fnum,'(3G18.10)') avec(1,2),avec(2,2),avec(3,2)
write(fnum,'(3G18.10)') avec(1,3),avec(2,3),avec(3,3)
write(fnum,*)
write(fnum,'("Reciprocal lattice vectors :")')
write(fnum,'(3G18.10)') bvec(1,1),bvec(2,1),bvec(3,1)
write(fnum,'(3G18.10)') bvec(1,2),bvec(2,2),bvec(3,2)
write(fnum,'(3G18.10)') bvec(1,3),bvec(2,3),bvec(3,3)
write(fnum,*)
write(fnum,'("Unit cell volume : ",G18.10)') omega
write(fnum,'("Brillouin zone volume : ",G18.10)') omegabz
write(fnum,*)
write(fnum,'("Muffin-tin inner radius fraction : ",G18.10)') fracinr
do is=1,nspecies
write(fnum,*)
write(fnum,'("Species : ",I4," (",A,")")') is,trim(spsymb(is))
write(fnum,'(" parameters loaded from : ",A)') trim(spfname(is))
write(fnum,'(" name : ",A)') trim(spname(is))
write(fnum,'(" nuclear charge : ",G18.10)') spzn(is)
write(fnum,'(" electronic charge : ",G18.10)') spze(is)
write(fnum,'(" atomic mass : ",G18.10)') spmass(is)
write(fnum,'(" muffin-tin radius : ",G18.10)') rmt(is)
write(fnum,'(" number of radial points in muffin-tin : ",I6)') nrmt(is)
write(fnum,'(" number on inner part of muffin-tin : ",I6)') nrmti(is)
write(fnum,'(" atomic positions (lattice), magnetic fields (Cartesian) :")')
do ia=1,natoms(is)
write(fnum,'(I4," : ",3F12.8," ",3F12.8)') ia,atposl(:,ia,is), &
bfcmt(:,ia,is)
end do
end do
write(fnum,*)
write(fnum,'("Total number of atoms per unit cell : ",I4)') natmtot
write(fnum,*)
write(fnum,'("Spin treatment :")')
if (spinpol) then
write(fnum,'(" spin-polarised")')
else
write(fnum,'(" spin-unpolarised")')
end if
if (spinorb) then
write(fnum,'(" spin-orbit coupling")')
end if
if (spincore) then
write(fnum,'(" spin-polarised core states")')
end if
if (spinpol) then
write(fnum,'(" global magnetic field (Cartesian) : ",3G18.10)') bfieldc
if (ncmag) then
write(fnum,'(" non-collinear magnetisation")')
else
write(fnum,'(" collinear magnetisation in z-direction")')
end if
end if
if (spinsprl) then
write(fnum,'(" spin-spiral state assumed")')
write(fnum,'(" q-vector (lattice) : ",3G18.10)') vqlss
write(fnum,'(" q-vector (Cartesian) : ",3G18.10)') vqcss
write(fnum,'(" q-vector length : ",G18.10)') sqrt(vqcss(1)**2 &
+vqcss(2)**2+vqcss(3)**2)
end if
if (fsmtype.ne.0) then
write(fnum,'(" fixed spin moment (FSM) calculation, type : ",I4)') fsmtype
if (fsmtype.lt.0) then
write(fnum,'(" only moment direction is fixed")')
end if
end if
if ((abs(fsmtype).eq.1).or.(abs(fsmtype).eq.3)) then
write(fnum,'(" fixing total moment to (Cartesian) :")')
write(fnum,'(" ",3G18.10)') momfix
end if
if ((abs(fsmtype).eq.2).or.(abs(fsmtype).eq.3)) then
write(fnum,'(" fixing local muffin-tin moments to (Cartesian) :")')
do is=1,nspecies
write(fnum,'(" species : ",I4," (",A,")")') is,trim(spsymb(is))
do ia=1,natoms(is)
write(fnum,'(" ",I4,3G18.10)') ia,mommtfix(:,ia,is)
end do
end do
end if
if (tssxc) then
write(fnum,'(" scaled spin exchange-correlation (SSXC) enabled")')
write(fnum,'(" scaling factor : ",G18.10)') ssxc
end if
if (ftmtype.ne.0) then
write(fnum,*)
write(fnum,'(" fixed tensor moment (FTM) calculation, type : ",I4)') ftmtype
end if
if (tefield) then
write(fnum,*)
write(fnum,'("Constant electric field applied across unit cell")')
write(fnum,'(" field strength : ",3G18.10)') efieldc
end if
if (tafield) then
write(fnum,*)
write(fnum,'("Constant A-field applied across unit cell")')
write(fnum,'(" field strength : ",3G18.10)') afieldc
end if
write(fnum,*)
write(fnum,'("Number of Bravais lattice symmetries : ",I4)') nsymlat
write(fnum,'("Number of crystal symmetries : ",I4)') nsymcrys
if (tsyminv) then
write(fnum,'("Crystal has inversion symmetry")')
else
write(fnum,'("Crystal has no inversion symmetry")')
end if
if (tefvr) then
write(fnum,'("Real symmetric eigensolver will be used")')
else
write(fnum,'("Complex Hermitian eigensolver will be used")')
end if
write(fnum,*)
if (autokpt) then
write(fnum,'("Radius of sphere used to determine k-point grid density : ",&
&G18.10)') radkpt
end if
write(fnum,'("k-point grid : ",3I6)') ngridk
write(fnum,'("k-point offset : ",3G18.10)') vkloff
if (reducek.eq.0) then
write(fnum,'("k-point set is not reduced")')
else if (reducek.eq.1) then
write(fnum,'("k-point set is reduced with full crystal symmetry group")')
else if (reducek.eq.2) then
write(fnum,'("k-point set is reduced with symmorphic symmetries only")')
else
write(*,*)
write(*,'("Error(writeinfo): undefined k-point reduction type : ",I8)') &
reducek
write(*,*)
stop
end if
write(fnum,'("Total number of k-points : ",I8)') nkpt
write(fnum,*)
write(fnum,'("Muffin-tin radius times maximum |G+k| : ",G18.10)') rgkmax
select case(isgkmax)
case(:-4)
write(fnum,'(" using largest radius")')
case(-3)
write(fnum,'(" using smallest radius")')
case(-2)
write(fnum,'(" using gkmax = rgkmax / 2")')
case(-1)
write(fnum,'(" using average radius")')
case(1:)
if (isgkmax.le.nspecies) then
write(fnum,'(" using radius of species ",I4," (",A,")")') isgkmax, &
trim(spsymb(isgkmax))
else
write(*,*)
write(*,'("Error(writeinfo): isgkmax > nspecies : ",2I8)') isgkmax,nspecies
write(*,*)
stop
end if
end select
write(fnum,'("Maximum |G+k| for APW functions : ",G18.10)') gkmax
write(fnum,'("Maximum (1/2)|G+k|^2 : ",G18.10)') 0.5d0*gkmax**2
write(fnum,'("Maximum |G| for potential and density : ",G18.10)') gmaxvr
write(fnum,'("Constant for pseudocharge density : ",I4)') npsd
write(fnum,'("Radial integration step length : ",I4)') lradstp
write(fnum,*)
write(fnum,'("G-vector grid sizes : ",3I6)') ngridg(:)
write(fnum,'("Number of G-vectors : ",I8)') ngvec
write(fnum,*)
write(fnum,'("Maximum angular momentum used for")')
write(fnum,'(" APW functions : ",I4)') lmaxapw
write(fnum,'(" outer part of muffin-tin : ",I4)') lmaxo
write(fnum,'(" inner part of muffin-tin : ",I4)') lmaxi
write(fnum,*)
write(fnum,'("Total nuclear charge : ",G18.10)') chgzn
write(fnum,'("Total core charge : ",G18.10)') chgcrtot
write(fnum,'("Total valence charge : ",G18.10)') chgval
write(fnum,'("Total excess charge : ",G18.10)') chgexs
write(fnum,'("Total electronic charge : ",G18.10)') chgtot
write(fnum,*)
write(fnum,'("Effective Wigner radius, r_s : ",G18.10)') rwigner
write(fnum,*)
write(fnum,'("Number of empty states : ",I4)') nempty
write(fnum,'("Total number of valence states : ",I4)') nstsv
write(fnum,'("Total number of core states : ",I4)') nstcr
write(fnum,*)
if (lorbcnd) then
write(fnum,'("Conduction state local-orbitals added automatically")')
end if
write(fnum,'("Total number of local-orbitals : ",I4)') nlotot
if (tefvit) then
write(fnum,*)
write(fnum,'("Using iterative diagonalisation for the first-variational &
&eigenvalue equation")')
end if
write(fnum,*)
if (task.eq.5) then
write(fnum,'("Hartree-Fock calculation using Kohn-Sham states")')
if (hybrid) then
write(fnum,'(" hybrid functional, coefficient : ",G18.10)') hybridc
end if
end if
if (xctype(1).eq.100) then
write(fnum,'("Using Libxc version ",I2.2,".",I2.2,".",I2.2)') libxcv(:)
end if
if (xctype(1).lt.0) then
write(fnum,'("Optimised effective potential (OEP) and exact exchange (EXX)")')
write(fnum,'(" Phys. Rev. B 53, 7024 (1996)")')
write(fnum,'("Correlation functional : ",3I6)') abs(xctype(1)),xctype(2:3)
write(fnum,'(" ",A)') trim(xcdescr)
else
write(fnum,'("Exchange-correlation functional : ",3I6)') xctype(:)
write(fnum,'(" ",A)') trim(xcdescr)
end if
if (xcgrad.eq.0) then
write(fnum,'(" Local density approximation (LDA)")')
else if ((xcgrad.eq.1).or.(xcgrad.eq.2)) then
write(fnum,'(" Generalised gradient approximation (GGA)")')
else if (xcgrad.eq.3) then
write(fnum,'(" meta-GGA; using kinetic energy density")')
end if
if (dftu.ne.0) then
write(fnum,*)
write(fnum,'("DFT+U calculation")')
if (dftu.eq.1) then
write(fnum,'(" fully localised limit (FLL)")')
write(fnum,'(" see Phys. Rev. B 52, R5467 (1995)")')
else if (dftu.eq.2) then
write(fnum,'(" around mean field (AMF)")')
write(fnum,'(" see Phys. Rev. B 49, 14211 (1994)")')
else if (dftu.eq.3) then
write(fnum,'(" interpolation between FLL and AMF")')
write(fnum,'(" see Phys. Rev. B 67, 153106 (2003)")')
else
write(*,*)
write(*,'("Error(writeinfo): dftu not defined : ",I8)') dftu
write(*,*)
stop
end if
do i=1,ndftu
is=idftu(1,i)
l=idftu(2,i)
if (inpdftu.eq.1) then
write(fnum,'(" species : ",I4," (",A,")",", l = ",I2,", U = ",F12.8, &
&", J = ",F12.8)') is,trim(spsymb(is)),l,ujdu(1,i),ujdu(2,i)
else if (inpdftu.eq.2) then
write(fnum,'(" species : ",I4," (",A,")",", l = ",I2)') is, &
trim(spsymb(is)),l
write(fnum,'(" Slater integrals are provided as input")')
do k=0,2*l,2
write(fnum,'(" F^(",I1,") = ",F12.8)') k,fdu(k,i)
end do
else if (inpdftu.eq.3) then
write(fnum,'(" species : ",I4," (",A,")",", l = ",I2)') is, &
trim(spsymb(is)),l
write(fnum,'(" Racah parameters are provided as input")')
do k=0,l
write(fnum,'(" E^(",I1,") = ",F12.8)') k,edu(k,i)
end do
else if (inpdftu.eq.4) then
write(fnum,'(" species : ",I4," (",A,")",", l = ",I2)') is, &
trim(spsymb(is)),l
write(fnum,'(" Slater integrals are calculated by means of Yukawa &
&potential")')
write(fnum,'(" Yukawa potential screening length (a.u^-1) : ",F12.8)') &
lambdadu(i)
else if(inpdftu.eq.5) then
write(fnum,'(" species : ",I4," (",A,")",", l = ",I2)') is, &
trim(spsymb(is)),l
write(fnum,'(" Slater integrals are calculated by means of Yukawa &
&potential")')
write(fnum,'(" Yukawa potential screening length corresponds to U = ",&
&F12.8)') udufix(i)
end if
end do
end if
if (task.eq.300) then
write(fnum,*)
write(fnum,'("RDMFT calculation")')
write(fnum,'(" see arXiv:0801.3787v1 [cond-mat.mtrl-sci]")')
write(fnum,'(" RDMFT exchange-correlation type : ",I4)') rdmxctype
if (rdmxctype.eq.1) then
write(fnum,'(" Hartree-Fock functional")')
else if (rdmxctype.eq.2) then
write(fnum,'(" Power functional, exponent : ",G18.10)') rdmalpha
end if
end if
write(fnum,*)
write(fnum,'("Smearing type : ",I4)') stype
write(fnum,'(" ",A)') trim(sdescr)
if (autoswidth) then
write(fnum,'("Automatic determination of smearing width")')
else
write(fnum,'("Smearing width : ",G18.10)') swidth
write(fnum,'("Effective electronic temperature (K) : ",G18.10)') tempk
end if
write(fnum,*)
write(fnum,'("Mixing type : ",I4)') mixtype
write(fnum,'(" ",A)') trim(mixdescr)
flush(fnum)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rfpack.f90 0000644 0000000 0000000 00000000132 13543334735 014415 x ustar 00 30 mtime=1569569245.244641552
30 atime=1569569241.483643954
30 ctime=1569569245.244641552
elk-6.3.2/src/rfpack.f90 0000644 0025044 0025044 00000001624 13543334735 016467 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 rfpack(tpack,n,np,ld,rfmt,rfir,v)
use modmain
implicit none
! arguments
logical, intent(in) :: tpack
integer, intent(inout) :: n
integer, intent(in) :: np(nspecies)
integer, intent(in) :: ld
real(8), intent(inout) :: rfmt(ld,natmtot),rfir(ngtot)
real(8), intent(out) :: v(*)
! local variables
integer is,ias
if (tpack) then
! pack the function
do ias=1,natmtot
is=idxis(ias)
call dcopy(np(is),rfmt(:,ias),1,v(n+1),1)
n=n+np(is)
end do
call dcopy(ngtot,rfir,1,v(n+1),1)
n=n+ngtot
else
! unpack the function
do ias=1,natmtot
is=idxis(ias)
call dcopy(np(is),v(n+1),1,rfmt(:,ias),1)
n=n+np(is)
end do
call dcopy(ngtot,v(n+1),1,rfir,1)
n=n+ngtot
end if
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/gaunt.f90 0000644 0000000 0000000 00000000132 13543334735 014265 x ustar 00 30 mtime=1569569245.248641549
30 atime=1569569241.488643951
30 ctime=1569569245.248641549
elk-6.3.2/src/gaunt.f90 0000644 0025044 0025044 00000004161 13543334735 016336 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: gaunt
! !INTERFACE:
real(8) function gaunt(l1,l2,l3,m1,m2,m3)
! !INPUT/OUTPUT PARAMETERS:
! l1, l2, l3 : angular momentum quantum numbers (in,integer)
! m1, m2, m3 : magnetic quantum numbers (in,integer)
! !DESCRIPTION:
! Returns the Gaunt coefficient given by
! $$ \langle Y^{l_1}_{m_1}|Y^{l_2}_{m_2}|Y^{l_3}_{m_3} \rangle
! = (-1)^{m_1}\left[\frac{(2l_1+1)(2l_2+1)(2l_3+1)}{4\pi} \right]
! ^{\frac{1}{2}}
! \begin{pmatrix} l_1 & l_2 & l_3 \\ 0 & 0 & 0 \end{pmatrix}
! \begin{pmatrix} l_1 & l_2 & l_3 \\ -m_1 & m_2 & m_3 \end{pmatrix}. $$
! Suitable for $l_i$ less than 50.
!
! !REVISION HISTORY:
! Created November 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: l1,l2,l3
integer, intent(in) :: m1,m2,m3
! local variables
integer j,j1,j2,j3,jh
real(8) t1
! real constant 1/sqrt(4*pi)
real(8), parameter :: c1=0.28209479177387814347d0
! external functions
real(8) wigner3j,factnm,factr
external wigner3j,factnm,factr
if ((l1.lt.0).or.(l2.lt.0).or.(l3.lt.0).or.(abs(m1).gt.l1).or.(abs(m2).gt.l2) &
.or.(abs(m3).gt.l3)) then
write(*,*)
write(*,'("Error(gaunt): non-physical arguments :")')
write(*,'("l1 = ",I8," l2 = ",I8," l3 = ",I8)') l1,l2,l3
write(*,'("m1 = ",I8," m2 = ",I8," m3 = ",I8)') m1,m2,m3
write(*,*)
stop
end if
if ((l1.gt.50).or.(l2.gt.50).or.(l3.gt.50)) then
write(*,*)
write(*,'("Error(gaunt): angular momenta out of range : ",3I8)') l1,l2,l3
write(*,*)
stop
end if
if (m1-m2-m3.ne.0) then
gaunt=0.d0
return
end if
j1=l2-l1+l3
j2=l1-l2+l3
j3=l1+l2-l3
if ((j1.lt.0).or.(j2.lt.0).or.(j3.lt.0)) then
gaunt=0.d0
return
end if
j=l1+l2+l3
if (mod(j,2).ne.0) then
gaunt=0.d0
return
end if
jh=j/2
t1=sqrt(dble((2*l1+1)*(2*l2+1)*(2*l3+1))*factr(j1,j+1)*factnm(j2,1) &
*factnm(j3,1))
t1=t1*factr(jh,jh-l1)/(factnm(jh-l2,1)*factnm(jh-l3,1))
gaunt=t1*c1*wigner3j(l1,l2,l3,-m1,m2,m3)
if (mod(m1+jh,2).ne.0) gaunt=-gaunt
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/readinput.f90 0000644 0000000 0000000 00000000132 13543334735 015142 x ustar 00 30 mtime=1569569245.256641544
30 atime=1569569241.492643948
30 ctime=1569569245.256641544
elk-6.3.2/src/readinput.f90 0000644 0025044 0025044 00000134753 13543334735 017226 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-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: readinput
! !INTERFACE:
subroutine readinput
! !USES:
use modmain
use moddftu
use modrdm
use modphonon
use modtest
use modrandom
use modscdft
use modpw
use modtddft
use modulr
use modvars
use modgw
use modjx
use modw90
use modmpi
use modomp
! !DESCRIPTION:
! Reads in the input parameters from the file {\tt elk.in}. Also sets default
! values for the input parameters.
!
! !REVISION HISTORY:
! Created September 2002 (JKD)
!EOP
!BOC
implicit none
! local variables
logical lv
integer is,ia,ias,ios
integer i,j,k,l,n,p
real(8) sc,sc1,sc2,sc3
real(8) scu,scu1,scu2,scu3
real(8) solscf,zn,a,b
real(8) axang(4),rot(3,3)
real(8) v1(3),v2(3),t1
character(256) block,symb,str
!------------------------!
! default values !
!------------------------!
ntasks=0
avec(:,:)=0.d0
avec(1,1)=1.d0
avec(2,2)=1.d0
avec(3,3)=1.d0
sc=1.d0
sc1=1.d0
sc2=1.d0
sc3=1.d0
epslat=1.d-6
primcell=.false.
tshift=.true.
ngridk(:)=1
vkloff(:)=0.d0
autokpt=.false.
radkpt=40.d0
reducek=1
ngridq(:)=-1
reduceq=1
rgkmax=7.d0
gmaxvr=12.d0
lmaxapw=8
lmaxo=6
lmaxi=1
fracinr=0.01d0
trhonorm=.true.
xctype(1)=3
xctype(2:3)=0
xctsp(1)=3
xctsp(2:3)=0
stype=3
swidth=0.001d0
autoswidth=.false.
mstar=10.d0
epsocc=1.d-8
epschg=1.d-3
nempty0=4.d0
maxscl=200
mixtype=3
amixpm(1)=0.05d0
amixpm(2)=1.d0
! Broyden parameters recommended by M. Meinert
mixsdb=5
broydpm(1)=0.4d0
broydpm(2)=0.15d0
epspot=1.d-6
epsengy=1.d-4
epsforce=5.d-3
epsstress=1.d-3
molecule=.false.
nspecies=0
natoms(:)=0
atposl(:,:,:)=0.d0
atposc(:,:,:)=0.d0
bfcmt0(:,:,:)=0.d0
sppath=''
scrpath=''
nvp1d=2
if (allocated(vvlp1d)) deallocate(vvlp1d)
allocate(vvlp1d(3,nvp1d))
vvlp1d(:,1)=0.d0
vvlp1d(:,2)=1.d0
npp1d=200
vclp2d(:,:)=0.d0
vclp2d(1,1)=1.d0
vclp2d(2,2)=1.d0
np2d(:)=40
vclp3d(:,:)=0.d0
vclp3d(1,1)=1.d0
vclp3d(2,2)=1.d0
vclp3d(3,3)=1.d0
np3d(:)=20
nwplot=500
ngrkf=100
nswplot=1
wplot(1)=-0.5d0
wplot(2)=0.5d0
dosocc=.false.
dosmsum=.false.
dosssum=.false.
lmirep=.true.
spinpol=.false.
spinorb=.false.
socscf=1.d0
atpopt=1
maxatpstp=200
tau0atp=0.25d0
deltast=0.001d0
latvopt=0
maxlatvstp=30
tau0latv=0.2d0
lradstp=4
chgexs=0.d0
scissor=0.d0
noptcomp=1
optcomp(:,1)=1
intraband=.false.
evaltol=-1.d0
epsband=1.d-12
demaxbnd=2.5d0
autolinengy=.false.
dlefe=-0.1d0
deapwlo=0.05d0
bfieldc0(:)=0.d0
efieldc(:)=0.d0
afieldc(:)=0.d0
fsmtype=0
momfix(:)=0.d0
mommtfix(:,:,:)=1.d6
taufsm=0.01d0
rmtdelta=0.05d0
isgkmax=-1
symtype=1
deltaph=0.005d0
nphwrt=1
if (allocated(vqlwrt)) deallocate(vqlwrt)
allocate(vqlwrt(3,nphwrt))
vqlwrt(:,:)=0.d0
notelns=0
tforce=.false.
maxitoep=200
tauoep=1.d0
nkstlist=1
kstlist(:,1)=1
vklem(:)=0.d0
deltaem=0.025d0
ndspem=1
nosource=.false.
spinsprl=.false.
ssdph=.true.
vqlss(:)=0.d0
nwrite=0
dftu=0
inpdftu=1
ndftu=0
ujdu(:,:)=0.d0
fdu(:,:)=0.d0
edu(:,:)=0.d0
lambdadu(:)=0.d0
udufix(:)=0.d0
lambdadu0(:)=0.d0
tmwrite=.false.
readadu=.false.
rdmxctype=2
rdmmaxscl=2
maxitn=200
maxitc=0
taurdmn=0.5d0
taurdmc=0.25d0
rdmalpha=0.565d0
rdmtemp=0.d0
reducebf=1.d0
ptnucl=.true.
tefvr=.true.
tefvit=.false.
minitefv=6
maxitefv=4
befvit=0.25d0
epsefvit=1.d-5
vecql(:)=0.d0
mustar=0.15d0
sqados(1:2)=0.d0
sqados(3)=1.d0
test=.false.
spincore=.false.
solscf=1.d0
emaxelnes=-1.2d0
wsfac(1)=-1.d6; wsfac(2)=1.d6
vhmat(:,:)=0.d0
vhmat(1,1)=1.d0
vhmat(2,2)=1.d0
vhmat(3,3)=1.d0
reduceh=.true.
hybrid=.false.
hybridc=1.d0
ecvcut=-3.5d0
esccut=-0.4d0
gmaxrf=3.d0
emaxrf=1.d6
ntemp=40
taubdg=0.1d0
nvbse0=2
ncbse0=3
nvxbse=0
ncxbse=0
bsefull=.false.
hxbse=.true.
hdbse=.true.
fxctype=-1
fxclrc(1)=0.d0
fxclrc(2)=0.d0
rndatposc=0.d0
rndbfcmt=0.d0
rndavec=0.d0
emaxbdg=0.5d0
c_tb09=0.d0
tc_tb09=.false.
rndachi=0.1d0
hmaxvr=20.d0
hkmax=12.d0
lorbcnd=.false.
lorbordc=3
nrmtscf=1.d0
lmaxdos=3
epsdev=0.005d0
msmooth=0
npmae0=-1
wrtvars=.false.
ftmtype=0
ntmfix=0
tauftm=0.5d0
ftmstep=1
cmagz=.false.
axang(:)=0.d0
dncgga=1.d-8
tstime=1000.d0
dtimes=0.1d0
npulse=0
nramp=0
ntswrite=10
nxoapwlo=0
nxlo=0
tdrho1d=.false.
tdrho2d=.false.
tdrho3d=.false.
tdmag2d=.false.
tdmag3d=.false.
tdcd2d=.false.
tdcd3d=.false.
tddos=.false.
tdlsj=.false.
rndevt0=0.d0
ssxc=1.d0
avecu(:,:)=0.d0
avecu(1,1)=1.d0
avecu(2,2)=1.d0
avecu(3,3)=1.d0
scu=1.d0
scu1=1.d0
scu2=1.d0
scu3=1.d0
q0cut=0.d0
rndbfcu=0.d0
efielduc(:)=0.d0
tplotq0=.true.
trdvclr=.false.
evtype=1
wmaxgw=-10.d0
twdiag=.false.
tsediag=.true.
actype=10
npole=3
nspade=100
maxitksi=200
tauksi=0.002d0
tfav0=.true.
nqssjx=1
thssjx(1)=0.d0
thssjx(2)=pi/6.d0
rmtall=-1.d0
maxthd=0
maxthd1=0
maxthdmkl=8
maxlvl=4
taudft=.false.
t0tdlr=0.d0
tdphi=0.d0
thetamld=89.d0*pi/180.d0
ntsbackup=0
! Wannier90 variables
seedname='wannier'
num_wann=0
num_bands=0
num_iter=1000
nxlwin=0
tbdip=.false.
tcden=.false.
!--------------------------!
! read from elk.in !
!--------------------------!
open(50,file='elk.in',status='OLD',form='FORMATTED',iostat=ios)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error opening elk.in")')
write(*,*)
stop
end if
10 continue
read(50,*,end=30) block
! check for a comment
if ((scan(trim(block),'!').eq.1).or.(scan(trim(block),'#').eq.1)) goto 10
select case(trim(block))
case('tasks')
do i=1,maxtasks
read(50,'(A256)',err=20) str
if (trim(str).eq.'') then
if (i.eq.1) then
write(*,*)
write(*,'("Error(readinput): no tasks to perform")')
write(*,*)
stop
end if
ntasks=i-1
goto 10
end if
read(str,*,iostat=ios) tasks(i)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading tasks")')
write(*,'("(blank line required after tasks block)")')
write(*,*)
stop
end if
end do
write(*,*)
write(*,'("Error(readinput): too many tasks")')
write(*,'("Adjust maxtasks in modmain and recompile code")')
write(*,*)
stop
case('species')
! generate a species file
call genspecies(50)
case('fspecies')
! generate fractional species files
do is=1,maxspecies
read(50,'(A256)',err=20) str
if (trim(str).eq.'') goto 10
read(str,*,iostat=ios) zn,symb
if (zn.gt.-1.d0+epsocc) then
write(*,*)
write(*,'("Error(readinput): fractional nuclear Z > -1 : ",G18.10)') zn
write(*,*)
stop
end if
call genfspecies(zn,symb)
end do
write(*,*)
write(*,'("Error(readinput): too many fractional nucleus species")')
write(*,*)
stop
case('avec')
read(50,*,err=20) avec(:,1)
read(50,*,err=20) avec(:,2)
read(50,*,err=20) avec(:,3)
case('scale')
read(50,*,err=20) sc
case('scale1')
read(50,*,err=20) sc1
case('scale2')
read(50,*,err=20) sc2
case('scale3')
read(50,*,err=20) sc3
case('epslat')
read(50,*,err=20) epslat
if (epslat.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): epslat <= 0 : ",G18.10)') epslat
write(*,*)
stop
end if
case('primcell')
read(50,*,err=20) primcell
case('tshift')
read(50,*,err=20) tshift
case('autokpt')
read(50,*,err=20) autokpt
case('radkpt')
read(50,*,err=20) radkpt
if (radkpt.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): radkpt <= 0 : ",G18.10)') radkpt
write(*,*)
stop
end if
case('ngridk')
read(50,*,err=20) ngridk(:)
if ((ngridk(1).le.0).or.(ngridk(2).le.0).or.(ngridk(3).le.0)) then
write(*,*)
write(*,'("Error(readinput): invalid ngridk : ",3I8)') ngridk
write(*,*)
stop
end if
autokpt=.false.
case('vkloff')
read(50,*,err=20) vkloff(:)
case('reducek')
read(50,*,err=20) reducek
case('ngridq')
read(50,*,err=20) ngridq(:)
if ((ngridq(1).le.0).or.(ngridq(2).le.0).or.(ngridq(3).le.0)) then
write(*,*)
write(*,'("Error(readinput): invalid ngridq : ",3I8)') ngridq
write(*,*)
stop
end if
case('reduceq')
read(50,*,err=20) reduceq
case('rgkmax')
read(50,*,err=20) rgkmax
if (rgkmax.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): rgkmax <= 0 : ",G18.10)') rgkmax
write(*,*)
stop
end if
case('gmaxvr')
read(50,*,err=20) gmaxvr
case('lmaxapw')
read(50,*,err=20) lmaxapw
if (lmaxapw.lt.0) then
write(*,*)
write(*,'("Error(readinput): lmaxapw < 0 : ",I8)') lmaxapw
write(*,*)
stop
end if
if (lmaxapw.ge.maxlapw) then
write(*,*)
write(*,'("Error(readinput): lmaxapw too large : ",I8)') lmaxapw
write(*,'("Adjust maxlapw in modmain and recompile code")')
write(*,*)
stop
end if
case('lmaxo','lmaxvr')
read(50,*,err=20) lmaxo
if (lmaxo.lt.3) then
write(*,*)
write(*,'("Error(readinput): lmaxo < 3 : ",I8)') lmaxo
write(*,*)
stop
end if
case('lmaxi','lmaxinr')
read(50,*,err=20) lmaxi
if (lmaxi.lt.1) then
write(*,*)
write(*,'("Error(readinput): lmaxi < 1 : ",I8)') lmaxi
write(*,*)
stop
end if
case('lmaxmat')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''lmaxmat'' is no longer used")')
case('fracinr')
read(50,*,err=20) fracinr
case('trhonorm')
read(50,*,err=20) trhonorm
case('spinpol')
read(50,*,err=20) spinpol
case('spinorb')
read(50,*,err=20) spinorb
case('socscf')
read(50,*,err=20) socscf
if (socscf.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): socscf < 0 : ",G18.10)') socscf
write(*,*)
stop
end if
case('xctype')
read(50,'(A256)',err=20) str
str=trim(str)//' 0 0'
read(str,*,err=20) xctype
case('xctsp')
read(50,'(A256)',err=20) str
str=trim(str)//' 0 0'
read(str,*,err=20) xctsp
case('stype')
read(50,*,err=20) stype
case('swidth')
read(50,*,err=20) swidth
if (swidth.lt.1.d-9) then
write(*,*)
write(*,'("Error(readinput): swidth too small or negative : ",G18.10)') &
swidth
write(*,*)
stop
end if
case('autoswidth')
read(50,*,err=20) autoswidth
case('mstar')
read(50,*,err=20) mstar
if (mstar.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): mstar <= 0 : ",G18.10)') mstar
write(*,*)
stop
end if
case('epsocc')
read(50,*,err=20) epsocc
if (epsocc.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): epsocc <= 0 : ",G18.10)') epsocc
write(*,*)
stop
end if
case('epschg')
read(50,*,err=20) epschg
if (epschg.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): epschg <= 0 : ",G18.10)') epschg
write(*,*)
stop
end if
case('nempty','nempty0')
read(50,*,err=20) nempty0
if (nempty0.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): nempty <= 0 : ",G18.10)') nempty0
write(*,*)
stop
end if
case('mixtype')
read(50,*,err=20) mixtype
case('amixpm','beta0','betamax')
if (trim(block).eq.'amixpm') then
read(50,*,err=20) amixpm(:)
else if (trim(block).eq.'beta0') then
read(50,*,err=20) amixpm(1)
else
read(50,*,err=20) amixpm(2)
end if
if (amixpm(1).lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): beta0 [amixpm(1)] < 0 : ",G18.10)') amixpm(1)
write(*,*)
stop
end if
if ((amixpm(2).lt.0.d0).or.(amixpm(2).gt.1.d0)) then
write(*,*)
write(*,'("Error(readinput): betamax [amixpm(2)] not in [0,1] : ",G18.10)')&
amixpm(2)
write(*,*)
stop
end if
case('mixsdb')
read(50,*,err=20) mixsdb
if (mixsdb.lt.2) then
write(*,*)
write(*,'("Error(readinput): mixsdb < 2 : ",I8)') mixsdb
write(*,*)
stop
end if
case('broydpm')
read(50,*,err=20) broydpm(:)
if ((broydpm(1).lt.0.d0).or.(broydpm(1).gt.1.d0).or. &
(broydpm(2).lt.0.d0).or.(broydpm(2).gt.1.d0)) then
write(*,*)
write(*,'("Error(readinput): invalid Broyden mixing parameters : ",&
&2G18.10)') broydpm
write(*,*)
stop
end if
case('maxscl')
read(50,*,err=20) maxscl
if (maxscl.lt.0) then
write(*,*)
write(*,'("Error(readinput): maxscl < 0 : ",I8)') maxscl
write(*,*)
stop
end if
case('epspot')
read(50,*,err=20) epspot
case('epsengy')
read(50,*,err=20) epsengy
case('epsforce')
read(50,*,err=20) epsforce
case('epsstress')
read(50,*,err=20) epsstress
case('sppath')
read(50,*,err=20) sppath
sppath=adjustl(sppath)
case('scrpath')
read(50,*,err=20) scrpath
case('molecule')
read(50,*,err=20) molecule
case('atoms')
read(50,*,err=20) 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 in modmain and recompile code")')
write(*,*)
stop
end if
do is=1,nspecies
read(50,*,err=20) spfname(is)
spfname(is)=adjustl(spfname(is))
read(50,*,err=20) natoms(is)
if (natoms(is).le.0) then
write(*,*)
write(*,'("Error(readinput): natoms <= 0 : ",I8)') natoms(is)
write(*,'(" for species ",I4)') is
write(*,*)
stop
end if
if (natoms(is).gt.maxatoms) then
write(*,*)
write(*,'("Error(readinput): natoms too large : ",I8)') natoms(is)
write(*,'(" for species ",I4)') is
write(*,'("Adjust maxatoms in modmain and recompile code")')
write(*,*)
stop
end if
do ia=1,natoms(is)
read(50,'(A256)',err=20) str
str=trim(str)//' 0.0 0.0 0.0'
read(str,*,err=20) atposl(:,ia,is),bfcmt0(:,ia,is)
end do
end do
case('plot1d')
read(50,*,err=20) nvp1d,npp1d
if (nvp1d.lt.1) then
write(*,*)
write(*,'("Error(readinput): nvp1d < 1 : ",I8)') nvp1d
write(*,*)
stop
end if
if (npp1d.lt.nvp1d) then
write(*,*)
write(*,'("Error(readinput): npp1d < nvp1d : ",2I8)') npp1d,nvp1d
write(*,*)
stop
end if
if (allocated(vvlp1d)) deallocate(vvlp1d)
allocate(vvlp1d(3,nvp1d))
do i=1,nvp1d
read(50,*,err=20) vvlp1d(:,i)
end do
case('plot2d')
read(50,*,err=20) vclp2d(:,0)
read(50,*,err=20) vclp2d(:,1)
read(50,*,err=20) vclp2d(:,2)
read(50,*,err=20) np2d(:)
if ((np2d(1).lt.1).or.(np2d(2).lt.1)) then
write(*,*)
write(*,'("Error(readinput): np2d < 1 : ",2I8)') np2d
write(*,*)
stop
end if
case('plot3d')
read(50,*,err=20) vclp3d(:,0)
read(50,*,err=20) vclp3d(:,1)
read(50,*,err=20) vclp3d(:,2)
read(50,*,err=20) vclp3d(:,3)
read(50,*,err=20) np3d(:)
if ((np3d(1).lt.1).or.(np3d(2).lt.1).or.(np3d(3).lt.1)) then
write(*,*)
write(*,'("Error(readinput): np3d < 1 : ",3I8)') np3d
write(*,*)
stop
end if
case('wplot','dos')
read(50,*,err=20) nwplot,ngrkf,nswplot
if (nwplot.lt.2) then
write(*,*)
write(*,'("Error(readinput): nwplot < 2 : ",I8)') nwplot
write(*,*)
stop
end if
if (ngrkf.lt.1) then
write(*,*)
write(*,'("Error(readinput): ngrkf < 1 : ",I8)') ngrkf
write(*,*)
stop
end if
if (nswplot.lt.0) then
write(*,*)
write(*,'("Error(readinput): nswplot < 0 : ",I8)') nswplot
write(*,*)
stop
end if
read(50,*,err=20) wplot(:)
if (wplot(1).gt.wplot(2)) then
write(*,*)
write(*,'("Error(readinput): wplot(1) > wplot(2) : ",2G18.10)') wplot
write(*,*)
stop
end if
case('dosocc')
read(50,*,err=20) dosocc
case('dosmsum')
read(50,*,err=20) dosmsum
case('dosssum')
read(50,*,err=20) dosssum
case('lmirep')
read(50,*,err=20) lmirep
case('atpopt')
read(50,*,err=20) atpopt
case('maxatpstp','maxatmstp')
read(50,*,err=20) maxatpstp
if (maxatpstp.le.0) then
write(*,*)
write(*,'("Error(readinput): maxatpstp <= 0 : ",I8)') maxatpstp
write(*,*)
stop
end if
case('tau0atp','tau0atm')
read(50,*,err=20) tau0atp
case('deltast')
read(50,*,err=20) deltast
if (deltast.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): deltast <= 0 : ",G18.10)') deltast
write(*,*)
stop
end if
case('latvopt')
read(50,*,err=20) latvopt
case('maxlatvstp')
read(50,*,err=20) maxlatvstp
if (maxlatvstp.le.0) then
write(*,*)
write(*,'("Error(readinput): maxlatvstp <= 0 : ",I8)') maxlatvstp
write(*,*)
stop
end if
case('tau0latv')
read(50,*,err=20) tau0latv
case('nstfsp')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''nstfsp'' is no longer used")')
case('lradstp')
read(50,*,err=20) lradstp
if (lradstp.le.0) then
write(*,*)
write(*,'("Error(readinput): lradstp <= 0 : ",I8)') lradstp
write(*,*)
stop
end if
case('chgexs')
read(50,*,err=20) chgexs
case('nprad')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''nprad'' is no longer used")')
case('scissor')
read(50,*,err=20) scissor
case('optcomp')
do i=1,27
read(50,'(A256)',err=20) str
if (trim(str).eq.'') then
if (i.eq.1) then
write(*,*)
write(*,'("Error(readinput): empty optical component list")')
write(*,*)
stop
end if
noptcomp=i-1
goto 10
end if
str=trim(str)//' 1 1'
read(str,*,iostat=ios) optcomp(:,i)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading optical component list")')
write(*,'("(blank line required after optcomp block)")')
write(*,*)
stop
end if
if ((optcomp(1,i).lt.1).or.(optcomp(1,i).gt.3).or. &
(optcomp(2,i).lt.1).or.(optcomp(2,i).gt.3).or. &
(optcomp(3,i).lt.1).or.(optcomp(3,i).gt.3)) then
write(*,*)
write(*,'("Error(readinput): invalid optcomp : ",3I8)') optcomp
write(*,*)
stop
end if
end do
write(*,*)
write(*,'("Error(readinput): optical component list too long")')
write(*,*)
stop
case('intraband')
read(50,*,err=20) intraband
case('evaltol')
read(50,*,err=20) evaltol
case('deband')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''deband'' is no longer used")')
case('epsband')
read(50,*,err=20) epsband
if (epsband.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): epsband <= 0 : ",G18.10)') epsband
write(*,*)
stop
end if
case('demaxbnd')
read(50,*,err=20) demaxbnd
if (demaxbnd.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): demaxbnd <= 0 : ",G18.10)') demaxbnd
write(*,*)
stop
end if
case('autolinengy')
read(50,*,err=20) autolinengy
case('dlefe')
read(50,*,err=20) dlefe
case('deapwlo')
read(50,*,err=20) deapwlo
if (abs(deapwlo).lt.1.d-8) then
write(*,*)
write(*,'("Error(readinput): invalid deapwlo : ",G18.10)') deapwlo
write(*,*)
stop
end if
case('bfieldc')
read(50,*,err=20) bfieldc0
case('efieldc')
read(50,*,err=20) efieldc
case('afieldc')
read(50,*,err=20) afieldc
case('fsmtype','fixspin')
read(50,*,err=20) fsmtype
case('momfix')
read(50,*,err=20) momfix
case('mommtfix')
do ias=1,maxspecies*maxatoms
read(50,'(A256)',err=20) str
if (trim(str).eq.'') goto 10
read(str,*,iostat=ios) is,ia,mommtfix(:,ia,is)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading muffin-tin fixed spin &
&moments")')
write(*,'("(blank line required after mommtfix block")')
write(*,*)
stop
end if
end do
case('taufsm')
read(50,*,err=20) taufsm
if (taufsm.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): taufsm < 0 : ",G18.10)') taufsm
write(*,*)
stop
end if
case('autormt')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''autormt'' is no longer used")')
case('rmtdelta')
read(50,*,err=20) rmtdelta
if (rmtdelta.lt.0.d0) then
write(*,*)
write(*,'("Warning(readinput): rmtdelta < 0 : ",G18.10)') rmtdelta
end if
case('isgkmax')
read(50,*,err=20) isgkmax
case('nosym')
read(50,*,err=20) lv
if (lv) symtype=0
case('symtype')
read(50,*,err=20) symtype
if ((symtype.lt.0).or.(symtype.gt.2)) then
write(*,*)
write(*,'("Error(readinput): symtype not defined : ",I8)') symtype
write(*,*)
stop
end if
case('deltaph')
read(50,*,err=20) deltaph
if (deltaph.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): deltaph <= 0 : ",G18.10)') deltaph
write(*,*)
stop
end if
case('phwrite')
read(50,*,err=20) nphwrt
if (nphwrt.le.0) then
write(*,*)
write(*,'("Error(readinput): nphwrt <= 0 : ",I8)') nphwrt
write(*,*)
stop
end if
if (allocated(vqlwrt)) deallocate(vqlwrt)
allocate(vqlwrt(3,nphwrt))
do i=1,nphwrt
read(50,*,err=20) vqlwrt(:,i)
end do
case('notes')
if (allocated(notes)) deallocate(notes)
allocate(notes(0))
notelns=0
do
read(50,'(A80)') str
if (trim(str).eq.'') goto 10
notelns=notelns+1
call addstr(notes)
end do
case('tforce')
read(50,*,err=20) tforce
case('tfibs')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''tfibs'' is no longer used")')
case('maxitoep')
read(50,*,err=20) maxitoep
if (maxitoep.lt.1) then
write(*,*)
write(*,'("Error(readinput): maxitoep < 1 : ",I8)') maxitoep
write(*,*)
stop
end if
case('tauoep')
read(50,*,err=20) tauoep
if (tauoep.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): tauoep < 0 : ",G18.10)') tauoep
write(*,*)
stop
end if
case('kstlist')
do i=1,maxkst
read(50,'(A256)',err=20) str
if (trim(str).eq.'') then
if (i.eq.1) then
write(*,*)
write(*,'("Error(readinput): empty k-point and state list")')
write(*,*)
stop
end if
nkstlist=i-1
goto 10
end if
read(str,*,iostat=ios) kstlist(:,i)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading k-point and state list")')
write(*,'("(blank line required after kstlist block)")')
write(*,*)
stop
end if
end do
write(*,*)
write(*,'("Error(readinput): k-point and state list too long")')
write(*,*)
stop
case('vklem')
read(50,*,err=20) vklem
case('deltaem')
read(50,*,err=20) deltaem
case('ndspem')
read(50,*,err=20) ndspem
if ((ndspem.lt.1).or.(ndspem.gt.4)) then
write(*,*)
write(*,'("Error(readinput): ndspem out of range : ",I8)') ndspem
write(*,*)
stop
end if
case('nosource')
read(50,*,err=20) nosource
case('spinsprl')
read(50,*,err=20) spinsprl
case('ssdph')
read(50,*,err=20) ssdph
case('vqlss')
read(50,*,err=20) vqlss
case('nwrite')
read(50,*,err=20) nwrite
case('DFT+U','dft+u','lda+u')
read(50,*,err=20) dftu,inpdftu
do i=1,maxdftu
read(50,'(A256)',err=20) str
if (trim(str).eq.'') then
ndftu=i-1
goto 10
end if
select case(inpdftu)
case(1)
read(str,*,iostat=ios) is,l,ujdu(1:2,i)
case(2)
read(str,*,iostat=ios) is,l,(fdu(k,i),k=0,2*l,2)
case(3)
read(str,*,iostat=ios) is,l,(edu(k,i),k=0,l)
case(4)
read(str,*,iostat=ios) is,l,lambdadu(i)
case(5)
read(str,*,iostat=ios) is,l,udufix(i)
case default
write(*,*)
write(*,'("Error(readinput): invalid inpdftu : ",I8)') inpdftu
write(*,*)
stop
end select
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading DFT+U parameters")')
write(*,'("(blank line required after dft+u block)")')
write(*,*)
stop
end if
if ((is.le.0).or.(is.ge.maxspecies)) then
write(*,*)
write(*,'("Error(readinput): invalid species number in dft+u block : ", &
&I8)') is
write(*,*)
stop
end if
if (l.lt.0) then
write(*,*)
write(*,'("Error(readinput): l < 0 in dft+u block : ",I8)') l
write(*,*)
stop
end if
if (l.gt.lmaxdm) then
write(*,*)
write(*,'("Error(readinput): l > lmaxdm in dft+u block : ",2I8)') l,lmaxdm
write(*,*)
stop
end if
! check for repeated entries
do j=1,i-1
if ((is.eq.idftu(1,j)).and.(l.eq.idftu(2,j))) then
write(*,*)
write(*,'("Error(readinput): repeated entry in DFT+U block")')
write(*,*)
stop
end if
end do
idftu(1,i)=is
idftu(2,i)=l
end do
write(*,*)
write(*,'("Error(readinput): too many DFT+U entries")')
write(*,'("Adjust maxdftu in modmain and recompile code")')
write(*,*)
stop
case('tmwrite','tmomlu')
read(50,*,err=20) tmwrite
case('readadu','readalu')
read(50,*,err=20) readadu
case('rdmxctype')
read(50,*,err=20) rdmxctype
case('rdmmaxscl')
read(50,*,err=20) rdmmaxscl
if (rdmmaxscl.lt.0) then
write(*,*)
write(*,'("Error(readinput): rdmmaxscl < 0 : ",I8)') rdmmaxscl
write(*,*)
end if
case('maxitn')
read(50,*,err=20) maxitn
if (maxitn.lt.1) then
write(*,*)
write(*,'("Error(readinput): maxitn < 1 : ",I8)') maxitn
write(*,*)
stop
end if
case('maxitc')
read(50,*,err=20) maxitc
case('taurdmn')
read(50,*,err=20) taurdmn
if (taurdmn.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): taurdmn < 0 : ",G18.10)') taurdmn
write(*,*)
stop
end if
case('taurdmc')
read(50,*,err=20) taurdmc
if (taurdmc.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): taurdmc < 0 : ",G18.10)') taurdmc
write(*,*)
stop
end if
case('rdmalpha')
read(50,*,err=20) rdmalpha
if ((rdmalpha.le.0.d0).or.(rdmalpha.ge.1.d0)) then
write(*,*)
write(*,'("Error(readinput): rdmalpha not in (0,1) : ",G18.10)') rdmalpha
write(*,*)
stop
end if
case('rdmtemp')
read(50,*,err=20) rdmtemp
if (rdmtemp.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): rdmtemp < 0 : ",G18.10)') rdmtemp
write(*,*)
stop
end if
case('reducebf')
read(50,*,err=20) reducebf
if ((reducebf.lt.0.49d0).or.(reducebf.gt.1.d0)) then
write(*,*)
write(*,'("Error(readinput): reducebf not in [0.5,1] : ",G18.10)') reducebf
write(*,*)
stop
end if
case('ptnucl')
read(50,*,err=20) ptnucl
case('tefvr','tseqr')
read(50,*,err=20) tefvr
case('tefvit','tseqit')
read(50,*,err=20) tefvit
case('minitefv','minseqit')
read(50,*,err=20) minitefv
if (minitefv.lt.1) then
write(*,*)
write(*,'("Error(readinput): minitefv < 1 : ",I8)') minitefv
write(*,*)
stop
end if
case('maxitefv','maxseqit')
read(50,*,err=20) maxitefv
if (maxitefv.lt.1) then
write(*,*)
write(*,'("Error(readinput): maxitefv < 1 : ",I8)') maxitefv
write(*,*)
stop
end if
case('befvit','bseqit')
read(50,*,err=20) befvit
if (befvit.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): befvit <= 0 : ",G18.10)') befvit
write(*,*)
stop
end if
case('epsefvit','epsseqit')
read(50,*,err=20) epsefvit
if (epsefvit.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): epsefvit < 0 : ",G18.10)') epsefvit
write(*,*)
stop
end if
case('nseqit')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''nseqit'' is no longer used")')
case('tauseq')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''tauseq'' is no longer used")')
case('vecql')
read(50,*,err=20) vecql(:)
case('mustar')
read(50,*,err=20) mustar
case('sqados')
read(50,*,err=20) sqados(:)
case('test')
read(50,*,err=20) test
case('frozencr')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''frozencr'' is no longer used")')
case('spincore')
read(50,*,err=20) spincore
case('solscf')
read(50,*,err=20) solscf
if (solscf.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): solscf < 0 : ",G18.10)') solscf
write(*,*)
stop
end if
case('emaxelnes')
read(50,*,err=20) emaxelnes
case('wsfac')
read(50,*,err=20) wsfac(:)
case('vhmat')
read(50,*,err=20) vhmat(1,:)
read(50,*,err=20) vhmat(2,:)
read(50,*,err=20) vhmat(3,:)
case('reduceh')
read(50,*,err=20) reduceh
case('hybrid')
read(50,*,err=20) hybrid
case('hybridc','hybmix')
read(50,*,err=20) hybridc
if ((hybridc.lt.0.d0).or.(hybridc.gt.1.d0)) then
write(*,*)
write(*,'("Error(readinput): invalid hybridc : ",G18.10)') hybridc
write(*,*)
stop
end if
case('ecvcut')
read(50,*,err=20) ecvcut
case('esccut')
read(50,*,err=20) esccut
case('nvbse')
read(50,*,err=20) nvbse0
if (nvbse0.lt.0) then
write(*,*)
write(*,'("Error(readinput): nvbse < 0 : ",I8)') nvbse0
write(*,*)
stop
end if
case('ncbse')
read(50,*,err=20) ncbse0
if (ncbse0.lt.0) then
write(*,*)
write(*,'("Error(readinput): ncbse < 0 : ",I8)') ncbse0
write(*,*)
stop
end if
case('istxbse')
do i=1,maxxbse
read(50,'(A256)',err=20) str
if (trim(str).eq.'') then
if (i.eq.1) then
write(*,*)
write(*,'("Error(readinput): empty BSE extra valence state list")')
write(*,*)
stop
end if
nvxbse=i-1
goto 10
end if
read(str,*,iostat=ios) istxbse(i)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading BSE valence state list")')
write(*,'("(blank line required after istxbse block)")')
write(*,*)
stop
end if
end do
write(*,*)
write(*,'("Error(readinput): BSE extra valence state list too long")')
write(*,*)
stop
case('jstxbse')
do i=1,maxxbse
read(50,'(A256)',err=20) str
if (trim(str).eq.'') then
if (i.eq.1) then
write(*,*)
write(*,'("Error(readinput): empty BSE extra conduction state list")')
write(*,*)
stop
end if
ncxbse=i-1
goto 10
end if
read(str,*,iostat=ios) jstxbse(i)
if (ios.ne.0) then
write(*,*)
write(*,'("Error(readinput): error reading BSE conduction state list")')
write(*,'("(blank line required after jstxbse block)")')
write(*,*)
stop
end if
end do
write(*,*)
write(*,'("Error(readinput): BSE extra conduction state list too long")')
write(*,*)
stop
case('bsefull')
read(50,*,err=20) bsefull
case('hxbse')
read(50,*,err=20) hxbse
case('hdbse')
read(50,*,err=20) hdbse
case('gmaxrf','gmaxrpa')
read(50,*,err=20) gmaxrf
if (gmaxrf.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): gmaxrf < 0 : ",G18.10)') gmaxrf
write(*,*)
stop
end if
case('emaxrf')
read(50,*,err=20) emaxrf
if (emaxrf.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): emaxrf < 0 : ",G18.10)') emaxrf
write(*,*)
stop
end if
case('fxctype')
read(50,'(A256)',err=20) str
str=trim(str)//' 0 0'
read(str,*,err=20) fxctype
case('fxclrc')
read(50,'(A256)',err=20) str
str=trim(str)//' 0.0'
read(str,*,err=20) fxclrc(:)
case('ntemp')
read(50,*,err=20) ntemp
if (ntemp.lt.1) then
write(*,*)
write(*,'("Error(readinput): ntemp < 1 : ",I8)') ntemp
write(*,*)
stop
end if
case('trimvg')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''trimvg'' is no longer used")')
write(*,'(" setting msmooth=4 instead")')
msmooth=4
case('rndstate','rndseed')
read(50,*,err=20) rndstate(0)
rndstate(0)=abs(rndstate(0))
case('taubdg')
read(50,*,err=20) taubdg
case('rndatposc')
read(50,*,err=20) rndatposc
case('rndbfcmt')
read(50,*,err=20) rndbfcmt
case('rndavec')
read(50,*,err=20) rndavec
case('emaxbdg')
read(50,*,err=20) emaxbdg
if (emaxbdg.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): emaxbdg <= 0 : ",G18.10)') emaxbdg
write(*,*)
stop
end if
case('c_tb09')
read(50,*,err=20) c_tb09
! set flag to indicate Tran-Blaha constant has been read in
tc_tb09=.true.
case('rndachi')
read(50,*,err=20) rndachi
case('lowq','highq','vhighq','uhighq')
read(50,*,err=20) lv
if (lv) then
if (trim(block).eq.'lowq') then
rgkmax=6.5d0
gmaxvr=10.d0
lmaxapw=7
lmaxo=5
nxlo=2
lorbcnd=.true.
radkpt=25.d0
autokpt=.true.
vkloff(:)=0.5d0
nempty0=4.d0
epspot=1.d-5
epsengy=5.d-4
epsforce=1.d-2
autolinengy=.true.
gmaxrf=2.5d0
lradstp=5
else if (trim(block).eq.'highq') then
! parameter set for high quality calculation
rgkmax=max(rgkmax,8.d0)
gmaxvr=max(gmaxvr,16.d0)
msmooth=max(msmooth,4)
lmaxapw=max(lmaxapw,9)
lmaxo=max(lmaxo,7)
nrmtscf=max(nrmtscf,1.5d0)
nxlo=max(nxlo,2)
lorbcnd=.true.
radkpt=max(radkpt,50.d0)
autokpt=.true.
vkloff(:)=0.d0
nempty0=max(nempty0,10.d0)
epspot=min(epspot,1.d-7)
epsengy=min(epsengy,1.d-5)
epsforce=min(epsforce,1.d-4)
autolinengy=.true.
gmaxrf=max(gmaxrf,4.d0)
else if (trim(block).eq.'vhighq') then
! parameter set for very high quality calculation
rgkmax=max(rgkmax,9.d0)
gmaxvr=max(gmaxvr,18.d0)
msmooth=max(msmooth,4)
lmaxapw=max(lmaxapw,10)
lmaxo=max(lmaxo,8)
nrmtscf=max(nrmtscf,2.d0)
nxlo=max(nxlo,3)
lorbcnd=.true.
radkpt=max(radkpt,90.d0)
autokpt=.true.
vkloff(:)=0.d0
nempty0=max(nempty0,20.d0)
epspot=min(epspot,1.d-7)
epsengy=min(epsengy,1.d-6)
epsforce=min(epsforce,1.d-4)
autolinengy=.true.
gmaxrf=max(gmaxrf,5.d0)
else
! parameter set for ultra high quality calculation
rgkmax=max(rgkmax,10.d0)
gmaxvr=max(gmaxvr,20.d0)
msmooth=max(msmooth,4)
lmaxapw=max(lmaxapw,11)
lmaxo=max(lmaxo,9)
nrmtscf=max(nrmtscf,4.d0)
nxlo=max(nxlo,3)
lorbcnd=.true.
radkpt=max(radkpt,120.d0)
autokpt=.true.
vkloff(:)=0.d0
nempty0=max(nempty0,40.d0)
epspot=min(epspot,1.d-7)
epsengy=min(epsengy,1.d-6)
epsforce=min(epsforce,1.d-4)
autolinengy=.true.
gmaxrf=max(gmaxrf,6.d0)
end if
if (mp_mpi) then
write(*,*)
write(*,'("Info(readinput): parameters set by ",A," option")') trim(block)
write(*,'(" rgkmax : ",G18.10)') rgkmax
write(*,'(" gmaxvr : ",G18.10)') gmaxvr
write(*,'(" msmooth : ",I4)') msmooth
write(*,'(" lmaxapw : ",I4)') lmaxapw
write(*,'(" lmaxo : ",I4)') lmaxo
write(*,'(" nrmtscf : ",G18.10)') nrmtscf
write(*,'(" nxlo : ",I4)') nxlo
write(*,'(" lorbcnd : ",L1)') lorbcnd
write(*,'(" radkpt : ",G18.10)') radkpt
write(*,'(" autokpt : ",L1)') autokpt
write(*,'(" vkloff : ",3G18.10)') vkloff
write(*,'(" nempty0 : ",G18.10)') nempty0
write(*,'(" epspot : ",G18.10)') epspot
write(*,'(" epsengy : ",G18.10)') epsengy
write(*,'(" epsforce : ",G18.10)') epsforce
write(*,'(" autolinengy : ",L1)') autolinengy
write(*,'(" gmaxrf : ",G18.10)') gmaxrf
if (trim(block).eq.'lowq') then
write(*,'(" lradstp : ",I4)') lradstp
end if
end if
end if
case('hmaxvr')
read(50,*,err=20) hmaxvr
if (hmaxvr.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): hmaxvr < 0 : ",G18.10)') hmaxvr
write(*,*)
stop
end if
case('hkmax')
read(50,*,err=20) hkmax
if (hkmax.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): hkmax <= 0 : ",G18.10)') hkmax
write(*,*)
stop
end if
case('lorbcnd')
read(50,*,err=20) lorbcnd
case('lorbordc')
read(50,*,err=20) lorbordc
if (lorbordc.lt.2) then
write(*,*)
write(*,'("Error(readinput): lorbordc < 2 : ",I8)') lorbordc
write(*,*)
stop
end if
if (lorbordc.gt.maxlorbord) then
write(*,*)
write(*,'("Error(readinput): lorbordc too large : ",I8)') lorbordc
write(*,'("Adjust maxlorbord in modmain and recompile code")')
write(*,*)
stop
end if
case('nrmtscf')
read(50,*,err=20) nrmtscf
if (nrmtscf.lt.0.5d0) then
write(*,*)
write(*,'("Error(readinput): nrmtscf < 0.5 : ",G18.10)') nrmtscf
write(*,*)
stop
end if
case('lmaxdos')
read(50,*,err=20) lmaxdos
if (lmaxdos.lt.0) then
write(*,*)
write(*,'("Error(readinput): lmaxdos < 0 : ",I8)') lmaxdos
write(*,*)
stop
end if
case('epsdev')
read(50,*,err=20) epsdev
if (epsdev.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): epsdev <= 0 : ",G18.10)') epsdev
write(*,*)
stop
end if
case('msmooth')
read(50,*,err=20) msmooth
if (msmooth.lt.0) then
write(*,*)
write(*,'("Error(readinput): msmooth < 0 : ",I8)') msmooth
write(*,*)
stop
end if
case('npmae')
read(50,*,err=20) npmae0
case('wrtvars')
read(50,*,err=20) wrtvars
case('ftmtype')
read(50,*,err=20) ftmtype
case('tmomfix')
read(50,*,err=20) ntmfix
if (ntmfix.le.0) then
write(*,*)
write(*,'("Error(readinput): ntmfix <= 0 : ",I8)') ntmfix
write(*,*)
stop
end if
if (allocated(itmfix)) deallocate(itmfix)
allocate(itmfix(8,ntmfix))
if (allocated(tmfix)) deallocate(tmfix)
allocate(tmfix(ntmfix))
if (allocated(rtmfix)) deallocate(rtmfix)
allocate(rtmfix(3,3,2,ntmfix))
do i=1,ntmfix
read(50,*,err=20) is,ia,l,n
if ((is.le.0).or.(ia.le.0).or.(l.lt.0).or.((n.ne.2).and.(n.ne.3))) then
write(*,*)
write(*,'("Error(readinput): invalid is, ia, l or n in tmomfix block : ",&
&4I8)') is,ia,l,n
write(*,*)
stop
end if
itmfix(1,i)=is
itmfix(2,i)=ia
itmfix(3,i)=l
itmfix(4,i)=n
! read k, p, x, y for the 2-index tensor or k, p, r, t for the 3-index tensor
read(50,*,err=20) itmfix(5:8,i)
! read tensor component
read(50,*,err=20) a,b
tmfix(i)=cmplx(a,b,8)
! read parity and Euler angles of spatial and spin rotation matrices
read(50,'(A256)',err=20) str
str=trim(str)//' 0.0 0.0 0.0'
read(str,*,err=20) p,v1(:),v2(:)
if (abs(p).ne.1) then
write(*,*)
write(*,'("Error(readinput): parity should be -1 or 1 in tmomfix &
&block : ",I8)') p
write(*,*)
stop
end if
! convert Euler angles from degrees to radians
v1(:)=v1(:)*pi/180.d0
v2(:)=v2(:)*pi/180.d0
! compute the spatial and spin 3x3 rotation matrices from the Euler angles
call eulerrot(v1,rtmfix(:,:,1,i))
call eulerrot(v2,rtmfix(:,:,2,i))
! multiply the spatial rotation matrix by the parity
rtmfix(:,:,1,i)=dble(p)*rtmfix(:,:,1,i)
end do
case('tauftm')
read(50,*,err=20) tauftm
if (tauftm.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): tauftm < 0 : ",G18.10)') tauftm
write(*,*)
stop
end if
case('ftmstep')
read(50,*,err=20) ftmstep
if (ftmstep.lt.1) then
write(*,*)
write(*,'("Error(readinput): ftmstep < 1 : ",I8)') ftmstep
write(*,*)
stop
end if
case('cmagz','forcecmag')
read(50,*,err=20) cmagz
case('rotavec')
read(50,*,err=20) axang(:)
case('tstime')
read(50,*,err=20) tstime
if (tstime.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): tstime <= 0 : ",G18.10)') tstime
write(*,*)
stop
end if
case('dtimes')
read(50,*,err=20) dtimes
if (dtimes.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): dtimes <= 0 : ",G18.10)') dtimes
write(*,*)
stop
end if
case('pulse')
read(50,*,err=20) npulse
if (npulse.lt.1) then
write(*,*)
write(*,'("Error(readinput): npulse < 1 : ",I8)') npulse
write(*,*)
stop
end if
if (allocated(pulse)) deallocate(pulse)
allocate(pulse(8,npulse))
do i=1,npulse
read(50,*,err=20) pulse(:,i)
end do
case('ramp')
read(50,*,err=20) nramp
if (nramp.lt.1) then
write(*,*)
write(*,'("Error(readinput): nramp < 1 : ",I8)') nramp
write(*,*)
stop
end if
if (allocated(ramp)) deallocate(ramp)
allocate(ramp(6,nramp))
do i=1,nramp
read(50,*,err=20) ramp(:,i)
end do
case('ncgga')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''ncgga'' is no longer used")')
case('dncgga')
read(50,*,err=20) dncgga
if (dncgga.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): dncgga < 0 : ",G18.10)') dncgga
write(*,*)
stop
end if
case('ntswrite')
read(50,*,err=20) ntswrite
case('nxoapwlo','nxapwlo')
read(50,*,err=20) nxoapwlo
if (nxoapwlo.lt.0) then
write(*,*)
write(*,'("Error(readinput): nxoapwlo < 0 : ",I8)') nxoapwlo
write(*,*)
stop
end if
case('nxlo')
read(50,*,err=20) nxlo
if (nxlo.lt.0) then
write(*,*)
write(*,'("Error(readinput): nxlo < 0 : ",I8)') nxlo
write(*,*)
stop
end if
case('tdrho1d')
read(50,*,err=20) tdrho1d
case('tdrho2d')
read(50,*,err=20) tdrho2d
case('tdrho3d')
read(50,*,err=20) tdrho3d
case('tdmag2d')
read(50,*,err=20) tdmag2d
case('tdmag3d')
read(50,*,err=20) tdmag3d
case('tdcd2d')
read(50,*,err=20) tdcd2d
case('tdcd3d')
read(50,*,err=20) tdcd3d
case('tddos')
read(50,*,err=20) tddos
case('tdlsj')
read(50,*,err=20) tdlsj
case('epseph')
read(50,*,err=20)
write(*,*)
write(*,'("Info(readinput): variable ''epseph'' is no longer used")')
case('rndevt0')
read(50,*,err=20) rndevt0
case('ssxc','rstsf')
read(50,*,err=20) ssxc
case('tempk')
read(50,*,err=20) tempk
if (tempk.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): tempk <= 0 : ",G18.10)') tempk
write(*,*)
stop
end if
! set Fermi-Dirac smearing
stype=3
! set the smearing width
swidth=kboltz*tempk
case('avecu')
read(50,*,err=20) avecu(:,1)
read(50,*,err=20) avecu(:,2)
read(50,*,err=20) avecu(:,3)
case('scaleu')
read(50,*,err=20) scu
case('scaleu1')
read(50,*,err=20) scu1
case('scaleu2')
read(50,*,err=20) scu2
case('scaleu3')
read(50,*,err=20) scu3
case('q0cut')
read(50,*,err=20) q0cut
if (q0cut.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): q0cut < 0 : ",G18.10)') q0cut
write(*,*)
stop
end if
case('rndbfcu')
read(50,*,err=20) rndbfcu
case('efielduc')
read(50,*,err=20) efielduc
case('tplotq0')
read(50,*,err=20) tplotq0
case('trdvclr')
read(50,*,err=20) trdvclr
case('evtype')
read(50,*,err=20) evtype
case('wmaxgw')
read(50,*,err=20) wmaxgw
case('twdiag')
read(50,*,err=20) twdiag
case('tsediag')
read(50,*,err=20) tsediag
case('actype')
read(50,*,err=20) actype
case('npole')
read(50,*,err=20) npole
if (npole.le.0) then
write(*,*)
write(*,'("Error(readinput): npole <= 0 : ",I8)') npole
write(*,*)
stop
end if
case('nspade')
read(50,*,err=20) nspade
if (nspade.le.0) then
write(*,*)
write(*,'("Error(readinput): nspade <= 0 : ",I8)') nspade
write(*,*)
stop
end if
case('maxitksi')
read(50,*,err=20) maxitksi
if (maxitksi.lt.1) then
write(*,*)
write(*,'("Error(readinput): maxitksi < 1 : ",I8)') maxitksi
write(*,*)
stop
end if
case('tauksi')
read(50,*,err=20) tauksi
if (tauksi.lt.0.d0) then
write(*,*)
write(*,'("Error(readinput): tauksi < 0 : ",G18.10)') tauksi
write(*,*)
stop
end if
case('tfav0')
read(50,*,err=20) tfav0
case('nqssjx')
read(50,*,err=20) nqssjx
if (nqssjx.lt.1) then
write(*,*)
write(*,'("Error(readinput): nqssjx < 1 : ",I8)') nqssjx
write(*,*)
stop
end if
case('thssjx')
read(50,*,err=20) thssjx(:)
! convert from radians to degrees
thssjx(:)=thssjx(:)*pi/180.d0
case('rmtall')
read(50,*,err=20) rmtall
case('maxthd','omp_num_threads','OMP_NUM_THREADS')
read(50,*,err=20) maxthd
case('maxthd1')
read(50,*,err=20) maxthd1
case('maxthdmkl')
read(50,*,err=20) maxthdmkl
case('maxlvl','omp_max_active_levels','OMP_MAX_ACTIVE_LEVELS')
read(50,*,err=20) maxlvl
if (maxlvl.lt.1) then
write(*,*)
write(*,'("Error(readinput): maxlvl < 1 : ",I8)') maxlvl
write(*,*)
stop
end if
case('stable')
read(50,*,err=20) lv
if (lv) then
nxoapwlo=max(nxoapwlo,1)
mixtype=3
broydpm(1)=min(broydpm(1),0.01d0)
broydpm(2)=min(broydpm(2),0.04d0)
msmooth=max(msmooth,8)
if (mp_mpi) then
write(*,*)
write(*,'("Info(readinput): parameters set by stable option")')
write(*,'(" nxoapwlo : ",I4)') nxoapwlo
write(*,'(" mixtype : ",I4)') mixtype
write(*,'(" broydpm : ",2G18.10)') broydpm
write(*,'(" msmooth : ",I4)') msmooth
end if
end if
case('metagga')
read(50,*,err=20) lv
if (lv) then
nempty0=max(nempty0,10.d0)
lradstp=1
nrmtscf=max(nrmtscf,2.d0)
msmooth=max(msmooth,4)
if (mp_mpi) then
write(*,*)
write(*,'("Info(readinput): parameters set by metagga option")')
write(*,'(" nempty0 : ",G18.10)') nempty0
write(*,'(" lradstp : ",I4)') lradstp
write(*,'(" nrmtscf : ",G18.10)') nrmtscf
write(*,'(" msmooth : ",I4)') msmooth
end if
end if
case('taudft')
read(50,*,err=20) taudft
case('t0tdlr')
read(50,*,err=20) t0tdlr
if (t0tdlr.le.0.d0) then
write(*,*)
write(*,'("Error(readinput): t0tdlr <= 0 : ",G18.10)') t0tdlr
write(*,*)
stop
end if
case('tdphi')
read(50,*,err=20) tdphi
! convert phase from degrees to radians
tdphi=tdphi*pi/180.d0
case('thetamld')
read(50,*,err=20) thetamld
! convert MLD angle from degrees to radians
thetamld=thetamld*pi/180.d0
case('ntsbackup')
read(50,*,err=20) ntsbackup
case('seedname')
read(50,*,err=20) seedname
seedname=adjustl(seedname)
case('num_wann')
read(50,*,err=20) num_wann
case('idxw90','wann_bands')
read(50,'(A256)',err=20) str
num_bands=1024
if (allocated(idxw90)) deallocate(idxw90)
allocate(idxw90(num_bands))
call numlist(str,num_bands,idxw90)
case('num_iter')
read(50,*,err=20) num_iter
case('xlwin','wannierExtra')
if (allocated(xlwin)) deallocate(xlwin)
allocate(xlwin(0))
nxlwin=0
do
read(50,'(A256)',err=20) str
if (trim(str).eq.'') goto 10
nxlwin=nxlwin+1
call addstr(xlwin)
end do
case('tbdip')
read(50,*,err=20) tbdip
case('tcden')
read(50,*,err=20) tcden
case('')
goto 10
case default
write(*,*)
write(*,'("Error(readinput): invalid block name : ",A)') trim(block)
write(*,*)
stop
end select
goto 10
20 continue
write(*,*)
write(*,'("Error(readinput): error reading from elk.in")')
write(*,'("Problem occurred in ''",A,"'' block")') trim(block)
write(*,'("Check input convention in manual")')
write(*,*)
stop
30 continue
close(50)
! scale the speed of light
solsc=sol*solscf
! scale and rotate the lattice vectors (not referenced again in code)
avec(:,1)=sc1*avec(:,1)
avec(:,2)=sc2*avec(:,2)
avec(:,3)=sc3*avec(:,3)
avec(:,:)=sc*avec(:,:)
t1=axang(4)
if (t1.ne.0.d0) then
t1=t1*pi/180.d0
call axangrot(axang(:),t1,rot)
do i=1,3
v1(:)=avec(:,i)
call r3mv(rot,v1,avec(:,i))
end do
end if
! randomise lattice vectors if required
if (rndavec.gt.0.d0) then
do i=1,3
do j=1,3
t1=rndavec*(randomu()-0.5d0)
avec(i,j)=avec(i,j)+t1
end do
end do
end if
! case of isolated molecule
if (molecule) then
! convert atomic positions from Cartesian to lattice coordinates
call r3minv(avec,ainv)
do is=1,nspecies
do ia=1,natoms(is)
call r3mv(ainv,atposl(:,ia,is),v1)
atposl(:,ia,is)=v1(:)
end do
end do
end if
! randomise atomic positions if required
if (rndatposc.gt.0.d0) then
call r3minv(avec,ainv)
do is=1,nspecies
do ia=1,natoms(is)
call r3mv(avec,atposl(:,ia,is),v1)
do i=1,3
t1=rndatposc*(randomu()-0.5d0)
v1(i)=v1(i)+t1
end do
call r3mv(ainv,v1,atposl(:,ia,is))
end do
end do
end if
! randomise the muffin-tin magnetic fields if required
if (rndbfcmt.gt.0.d0) then
do is=1,nspecies
do ia=1,natoms(is)
do i=1,3
t1=rndbfcmt*(randomu()-0.5d0)
bfcmt0(i,ia,is)=bfcmt0(i,ia,is)+t1
end do
end do
end do
end if
! set fxctype to fxctype if required
if (fxctype(1).eq.-1) fxctype(:)=xctype(:)
! find primitive cell if required
if (primcell) call findprimcell
! scale the ultracell vectors if required
avecu(:,1)=scu1*avecu(:,1)
avecu(:,2)=scu2*avecu(:,2)
avecu(:,3)=scu3*avecu(:,3)
avecu(:,:)=scu*avecu(:,:)
! read in atomic species data
call readspecies
return
contains
subroutine addstr(slist)
implicit none
! arguments
character(256), intent(inout), allocatable :: slist(:)
! allocatable arrays
character(256), allocatable :: stmp(:)
n=size(slist)
allocate(stmp(n))
stmp(1:n)=slist(1:n)
deallocate(slist)
allocate(slist(n+1))
slist(1:n)=stmp(1:n)
slist(n+1)=str
deallocate(stmp)
return
end subroutine
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/ztorfmt.f90 0000644 0000000 0000000 00000000132 13543334735 014654 x ustar 00 30 mtime=1569569245.261641541
30 atime=1569569241.501643943
30 ctime=1569569245.261641541
elk-6.3.2/src/ztorfmt.f90 0000644 0025044 0025044 00000001063 13543334735 016723 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2013 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 ztorfmt(nr,nri,zfmt,rfmt)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri
complex(8), intent(in) :: zfmt(*)
real(8), intent(out) :: rfmt(*)
! local variables
integer ir,i
i=1
do ir=1,nri
call ztorflm(lmaxi,zfmt(i),rfmt(i))
i=i+lmmaxi
end do
do ir=nri+1,nr
call ztorflm(lmaxo,zfmt(i),rfmt(i))
i=i+lmmaxo
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/putevecfv.f90 0000644 0000000 0000000 00000000131 13543334735 015155 x ustar 00 30 mtime=1569569245.265641539
29 atime=1569569241.50564394
30 ctime=1569569245.265641539
elk-6.3.2/src/putevecfv.f90 0000644 0025044 0025044 00000001723 13543334735 017230 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 putevecfv(fext,ik,evecfv)
use modmain
implicit none
! arguments
character(*), intent(in) :: fext
integer, intent(in) :: ik
complex(8), intent(in) :: evecfv(nmatmax,nstfv,nspnfv)
! local variables
integer recl,i
character(256) fname
! find the record length
inquire(iolength=recl) vkl(:,ik),nmatmax,nstfv,nspnfv,evecfv
fname=trim(scrpath)//'EVECFV'//trim(fext)
!$OMP CRITICAL(u122)
do i=1,2
open(122,file=trim(fname),form='UNFORMATTED',access='DIRECT',recl=recl,err=10)
write(122,rec=ik,err=10) vkl(:,ik),nmatmax,nstfv,nspnfv,evecfv
close(122)
exit
10 continue
if (i.eq.2) then
write(*,*)
write(*,'("Error(putevecfv): unable to write to ",A)') trim(fname)
write(*,*)
stop
end if
close(122)
end do
!$OMP END CRITICAL(u122)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/zfmtinp.f90 0000644 0000000 0000000 00000000132 13543334735 014636 x ustar 00 30 mtime=1569569245.269641536
30 atime=1569569241.509643938
30 ctime=1569569245.269641536
elk-6.3.2/src/zfmtinp.f90 0000644 0025044 0025044 00000004141 13543334735 016705 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: zfmtinp
! !INTERFACE:
complex(8) function zfmtinp(nr,nri,wr,zfmt1,zfmt2)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! nr : number of radial mesh points (in,integer)
! nri : number of points on the inner part of the muffin-tin (in,integer)
! wr : weights for integration on radial mesh (in,real(nr))
! zfmt1 : first complex muffin-tin function in spherical harmonics
! (in,complex(*))
! zfmt2 : second complex muffin-tin function (in,complex(*))
! !DESCRIPTION:
! Calculates the inner product of two complex fuctions in the muffin-tin. In
! other words, given two complex functions of the form
! $$ f({\bf r})=\sum_{l=0}^{l_{\rm max}}\sum_{m=-l}^{l}f_{lm}(r)Y_{lm}
! (\hat{\bf r}), $$
! the function returns
! $$ I=\sum_{l=0}^{l_{\rm max}}\sum_{m=-l}^{l}\int f_{lm}^{1*}(r)
! f_{lm}^2(r)r^2\,dr\;. $$
!
! !REVISION HISTORY:
! Created November 2003 (Sharma)
! Modified, September 2013 (JKD)
! Modified for packed functions, June 2016 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: wr(nr)
complex(8), intent(in) :: zfmt1(*),zfmt2(*)
! local variables
integer ir,i
complex(8) z1
! automatic arrays
real(8) fr1(nr),fr2(nr)
! external functions
complex(8) zdotc
external zdotc
! compute the dot-products for each radial point
i=1
if (lmaxi.eq.1) then
do ir=1,nri
z1=conjg(zfmt1(i))*zfmt2(i) &
+conjg(zfmt1(i+1))*zfmt2(i+1) &
+conjg(zfmt1(i+2))*zfmt2(i+2) &
+conjg(zfmt1(i+3))*zfmt2(i+3)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+4
end do
else
do ir=1,nri
z1=zdotc(lmmaxi,zfmt1(i),1,zfmt2(i),1)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+lmmaxi
end do
end if
do ir=nri+1,nr
z1=zdotc(lmmaxo,zfmt1(i),1,zfmt2(i),1)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+lmmaxo
end do
! integrate over r
zfmtinp=cmplx(dot_product(wr(:),fr1(:)),dot_product(wr(:),fr2(:)),8)
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/zfcmtinp.f90 0000644 0000000 0000000 00000000132 13543334735 015001 x ustar 00 30 mtime=1569569245.274641533
30 atime=1569569241.514643934
30 ctime=1569569245.274641533
elk-6.3.2/src/zfcmtinp.f90 0000644 0025044 0025044 00000002335 13543334735 017053 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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.
complex(8) function zfcmtinp(nr,nri,wr,zfmt1,zfmt2)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: wr(nr)
complex(8), intent(in) :: zfmt1(*),zfmt2(*)
! local variables
integer ir,i
real(8) t1
complex(8) z1
! automatic arrays
real(8) fr1(nr),fr2(nr)
! external functions
complex(8) zdotc
external zdotc
! compute the dot-products for each radial point
i=1
if (lmaxi.eq.1) then
do ir=1,nri
z1=conjg(zfmt1(i))*zfmt2(i) &
+conjg(zfmt1(i+1))*zfmt2(i+1) &
+conjg(zfmt1(i+2))*zfmt2(i+2) &
+conjg(zfmt1(i+3))*zfmt2(i+3)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+4
end do
else
do ir=1,nri
z1=zdotc(lmmaxi,zfmt1(i),1,zfmt2(i),1)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+lmmaxi
end do
end if
t1=dble(lmmaxi)/dble(lmmaxo)
do ir=nri+1,nr
z1=t1*zdotc(lmmaxo,zfmt1(i),1,zfmt2(i),1)
fr1(ir)=dble(z1); fr2(ir)=aimag(z1)
i=i+lmmaxo
end do
! integrate over r
t1=fourpi/dble(lmmaxi)
zfcmtinp=t1*cmplx(dot_product(wr(:),fr1(:)),dot_product(wr(:),fr2(:)),8)
return
end function
elk-6.3.2/src/PaxHeaders.21352/writelinen.f90 0000644 0000000 0000000 00000000130 13543334735 015325 x ustar 00 29 mtime=1569569245.27864153
30 atime=1569569241.519643931
29 ctime=1569569245.27864153
elk-6.3.2/src/writelinen.f90 0000644 0025044 0025044 00000002433 13543334735 017400 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: writelinen
! !INTERFACE:
subroutine writelinen
! !USES:
use modmain
! !DESCRIPTION:
! Writes the linearisation energies for all APW and local-orbital functions to
! the file {\tt LINENGY.OUT}.
!
! !REVISION HISTORY:
! Created February 2004 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ia,ias,l,io,ilo
open(50,file='LINENGY'//trim(filext),form='FORMATTED')
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
write(50,*)
write(50,'("Species : ",I4," (",A,"), atom : ",I4)') is,trim(spsymb(is)),ia
write(50,'(" APW functions :")')
do l=0,lmaxapw
do io=1,apword(l,is)
write(50,'(" l = ",I2,", energy derivative = ",I2," : ",G18.10)') l, &
apwdm(io,l,is),apwe(io,l,ias)
end do
end do
write(50,'(" local-orbital functions :")')
do ilo=1,nlorb(is)
do io=1,lorbord(ilo,is)
write(50,'(" l.o. = ",I2,", l = ",I2,", energy derivative = ",I2,&
&" : ",G18.10)') ilo,lorbl(ilo,is),lorbdm(io,ilo,is),lorbe(io,ilo,ias)
end do
end do
end do
end do
close(50)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/writekpts.f90 0000644 0000000 0000000 00000000132 13543334735 015203 x ustar 00 30 mtime=1569569245.282641528
30 atime=1569569241.524643928
30 ctime=1569569245.282641528
elk-6.3.2/src/writekpts.f90 0000644 0025044 0025044 00000001402 13543334735 017247 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: writekpts
! !INTERFACE:
subroutine writekpts
! !USES:
use modmain
! !DESCRIPTION:
! Writes the $k$-points in lattice coordinates, weights and number of
! ${\bf G+k}$-vectors to the file {\tt KPOINTS.OUT}.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer ik
open(50,file='KPOINTS'//trim(filext),form='FORMATTED')
write(50,'(I6," : nkpt; k-point, vkl, wkpt, nmat below")') nkpt
do ik=1,nkpt
write(50,'(I6,4G18.10,2I8)') ik,vkl(:,ik),wkpt(ik),nmat(:,ik)
end do
close(50)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rfmtinp.f90 0000644 0000000 0000000 00000000132 13543334735 014626 x ustar 00 30 mtime=1569569245.286641525
30 atime=1569569241.528643925
30 ctime=1569569245.286641525
elk-6.3.2/src/rfmtinp.f90 0000644 0025044 0025044 00000003517 13543334735 016703 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2003-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: rfmtinp
! !INTERFACE:
real(8) function rfmtinp(nr,nri,wr,rfmt1,rfmt2)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! nr : number of radial mesh points (in,integer)
! nri : number of radial mesh points on the inner part of the muffin-tin
! (in,integer)
! wr : weights for integration on radial mesh (in,real(nr))
! rfmt1 : first real function inside muffin-tin (in,real(*))
! rfmt2 : second real function inside muffin-tin (in,real(*))
! !DESCRIPTION:
! Calculates the inner product of two real functions in the muffin-tin. So
! given two real functions of the form
! $$ f({\bf r})=\sum_{l=0}^{l_{\rm max}}\sum_{m=-l}^{l}f_{lm}(r)R_{lm}
! (\hat{\bf r}) $$
! where $R_{lm}$ are the real spherical harmonics, the function returns
! $$ I=\int\sum_{l=0}^{l_{\rm max}}\sum_{m=-l}^{l}f_{lm}^1(r)f_{lm}^2(r)r^2
! dr\;. $$
!
! !REVISION HISTORY:
! Created November 2003 (Sharma)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nr,nri
real(8), intent(in) :: wr(nr)
real(8), intent(in) :: rfmt1(*),rfmt2(*)
! local variables
integer n,ir,i
! automatic arrays
real(8) fr(nr)
i=1
! inner part of muffin-tin
if (lmaxi.eq.1) then
do ir=1,nri
fr(ir)=rfmt1(i)*rfmt2(i) &
+rfmt1(i+1)*rfmt2(i+1) &
+rfmt1(i+2)*rfmt2(i+2) &
+rfmt1(i+3)*rfmt2(i+3)
i=i+4
end do
else
n=lmmaxi-1
do ir=1,nri
fr(ir)=dot_product(rfmt1(i:i+n),rfmt2(i:i+n))
i=i+lmmaxi
end do
end if
! outer part of muffin-tin
n=lmmaxo-1
do ir=nri+1,nr
fr(ir)=dot_product(rfmt1(i:i+n),rfmt2(i:i+n))
i=i+lmmaxo
end do
! integrate
rfmtinp=dot_product(wr(:),fr(:))
return
end function
!EOC
elk-6.3.2/src/PaxHeaders.21352/brzint.f90 0000644 0000000 0000000 00000000132 13543334735 014457 x ustar 00 30 mtime=1569569245.291641522
30 atime=1569569241.533643922
30 ctime=1569569245.291641522
elk-6.3.2/src/brzint.f90 0000644 0025044 0025044 00000011136 13543334735 016530 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: brzint
! !INTERFACE:
subroutine brzint(nsm,ngridk,nsk,ivkik,nw,wint,n,ld,e,f,g)
! !INPUT/OUTPUT PARAMETERS:
! nsm : level of smoothing for output function (in,integer)
! ngridk : k-point grid size (in,integer(3))
! nsk : k-point subdivision grid size (in,integer(3))
! ivkik : map from (i1,i2,i3) to k-point index
! (in,integer(0:ngridk(1)-1,0:ngridk(2)-1,0:ngridk(3)-1))
! nw : number of energy divisions (in,integer)
! wint : energy interval (in,real(2))
! n : number of functions to integrate (in,integer)
! ld : leading dimension (in,integer)
! e : array of energies as a function of k-points (in,real(ld,*))
! f : array of weights as a function of k-points (in,real(ld,*))
! g : output function (out,real(nw))
! !DESCRIPTION:
! Given energy and weight functions, $e$ and $f$, on the Brillouin zone and a
! set of equidistant energies $\omega_i$, this routine computes the integrals
! $$ g(\omega_i)=\frac{\Omega}{(2\pi)^3}\int_{\rm BZ} f({\bf k})
! \delta(\omega_i-e({\bf k}))d{\bf k}, $$
! where $\Omega$ is the unit cell volume. This is done by first interpolating
! $e$ and $f$ on a finer $k$-point grid using the trilinear method. Then for
! each $e({\bf k})$ on the finer grid the nearest $\omega_i$ is found and
! $f({\bf k})$ is accumulated in $g(\omega_i)$. If the output function is
! noisy then either {\tt nsk} should be increased or {\tt nw} decreased.
! Alternatively, the output function can be artificially smoothed up to a
! level given by {\tt nsm}. See routine {\tt fsmooth}.
!
! !REVISION HISTORY:
! Created October 2003 (JKD)
! Improved efficiency May 2007 (Sebastian Lebegue)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nsm,ngridk(3),nsk(3)
integer, intent(in) :: ivkik(0:ngridk(1)-1,0:ngridk(2)-1,0:ngridk(3)-1)
integer, intent(in) :: nw
real(8), intent(in) :: wint(2)
integer, intent(in) :: n,ld
real(8), intent(in) :: e(ld,*),f(ld,*)
real(8), intent(out) :: g(nw)
! local variables
integer i1,i2,i3,j1,j2,j3,k1,k2,k3,i,iw
integer i000,i001,i010,i011,i100,i101,i110,i111
real(8) es,fs,wd,dw,dwi,w1,t1,t2
! allocatable arrays
real(8), allocatable :: f0(:),f1(:),e0(:),e1(:)
real(8), allocatable :: f00(:),f01(:),f10(:),f11(:)
real(8), allocatable :: e00(:),e01(:),e10(:),e11(:)
if ((ngridk(1).lt.1).or.(ngridk(2).lt.1).or.(ngridk(3).lt.1)) then
write(*,*)
write(*,'("Error(brzint): ngridk < 1 : ",3I8)') ngridk
write(*,*)
stop
end if
if ((nsk(1).lt.1).or.(nsk(2).lt.1).or.(nsk(3).lt.1)) then
write(*,*)
write(*,'("Error(brzint): nsk < 1 : ",3I8)') nsk
write(*,*)
stop
end if
allocate(f0(n),f1(n),e0(n),e1(n))
allocate(f00(n),f01(n),f10(n),f11(n))
allocate(e00(n),e01(n),e10(n),e11(n))
! length of interval
wd=wint(2)-wint(1)
! energy step size
dw=wd/dble(nw)
dwi=1.d0/dw
w1=wint(1)
g(:)=0.d0
do j1=0,ngridk(1)-1
k1=mod(j1+1,ngridk(1))
do j2=0,ngridk(2)-1
k2=mod(j2+1,ngridk(2))
do j3=0,ngridk(3)-1
k3=mod(j3+1,ngridk(3))
i000=ivkik(j1,j2,j3); i001=ivkik(j1,j2,k3)
i010=ivkik(j1,k2,j3); i011=ivkik(j1,k2,k3)
i100=ivkik(k1,j2,j3); i101=ivkik(k1,j2,k3)
i110=ivkik(k1,k2,j3); i111=ivkik(k1,k2,k3)
do i1=0,nsk(1)-1
t2=dble(i1)/dble(nsk(1))
t1=1.d0-t2
f00(:)=f(:,i000)*t1+f(:,i100)*t2
f01(:)=f(:,i001)*t1+f(:,i101)*t2
f10(:)=f(:,i010)*t1+f(:,i110)*t2
f11(:)=f(:,i011)*t1+f(:,i111)*t2
e00(:)=e(:,i000)*t1+e(:,i100)*t2
e01(:)=e(:,i001)*t1+e(:,i101)*t2
e10(:)=e(:,i010)*t1+e(:,i110)*t2
e11(:)=e(:,i011)*t1+e(:,i111)*t2
do i2=0,nsk(2)-1
t2=dble(i2)/dble(nsk(2))
t1=1.d0-t2
f0(:)=f00(:)*t1+f10(:)*t2
f1(:)=f01(:)*t1+f11(:)*t2
e0(:)=e00(:)*t1+e10(:)*t2
e1(:)=e01(:)*t1+e11(:)*t2
do i3=0,nsk(3)-1
t2=dble(i3)/dble(nsk(3))
t1=1.d0-t2
do i=1,n
fs=f0(i)*t1+f1(i)*t2
es=e0(i)*t1+e1(i)*t2
iw=nint((es-w1)*dwi)+1
if ((iw.ge.1).and.(iw.le.nw)) g(iw)=g(iw)+fs
end do
end do
end do
end do
end do
end do
end do
! normalise function
t1=dw*dble(ngridk(1)*ngridk(2)*ngridk(3))*dble(nsk(1)*nsk(2)*nsk(3))
t1=1.d0/t1
g(:)=t1*g(:)
! smooth output function if required
if (nsm.gt.0) call fsmooth(nsm,nw,g)
deallocate(f0,f1,e0,e1)
deallocate(f00,f01,f10,f11)
deallocate(e00,e01,e10,e11)
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/rhocore.f90 0000644 0000000 0000000 00000000127 13543334735 014614 x ustar 00 29 mtime=1569569245.29564152
29 atime=1569569241.53764392
29 ctime=1569569245.29564152
elk-6.3.2/src/rhocore.f90 0000644 0025044 0025044 00000004054 13543334735 016662 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: rhocore
! !INTERFACE:
subroutine rhocore
! !USES:
use modmain
! !DESCRIPTION:
! Adds the core density and magnetisation to the muffin-tin functions. Also
! computes the amount of leakage of core charge from the muffin-tin spheres
! into the interstitial.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
! Fixed core moment direction, October 2012 (M. Meinert)
!EOP
!BOC
implicit none
! local variables
integer ispn,idm,is,ias
integer nr,nri,iro,ir,i
real(8) v(ndmag),sum,t1
! automatic arrays
real(8) fr(nrmtmax)
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
iro=nri+1
sum=0.d0
! loop over spin channels
do ispn=1,nspncr
! add the core density to the muffin-tin density
i=1
do ir=1,nri
rhomt(i,ias)=rhomt(i,ias)+rhocr(ir,ias,ispn)
i=i+lmmaxi
end do
do ir=iro,nr
rhomt(i,ias)=rhomt(i,ias)+rhocr(ir,ias,ispn)
i=i+lmmaxo
end do
! compute the core charge inside the muffin-tins
t1=dot_product(wrmt(1:nr,is),rhocr(1:nr,ias,ispn))
sum=sum+fourpi*y00*t1
end do
! core leakage charge
chgcrlk(ias)=chgcr(is)-sum
! add to the magnetisation in the case of a spin-polarised core
if (spincore) then
! compute the moment in the muffin-tin
do idm=1,ndmag
call rfmtlm(1,nr,nri,magmt(:,ias,idm),fr)
t1=dot_product(wrmt(1:nr,is),fr(1:nr))
v(idm)=fourpi*y00*t1
end do
! normalise
if (ncmag) then
t1=sqrt(v(1)**2+v(2)**2+v(3)**2)
else
t1=abs(v(1))
end if
if (t1.gt.1.d-10) v(:)=v(:)/t1
! add the core magnetisation to the total
i=1
do ir=1,nri
t1=abs(rhocr(ir,ias,1)-rhocr(ir,ias,2))
magmt(i,ias,:)=magmt(i,ias,:)+t1*v(:)
i=i+lmmaxi
end do
do ir=iro,nr
t1=abs(rhocr(ir,ias,1)-rhocr(ir,ias,2))
magmt(i,ias,:)=magmt(i,ias,:)+t1*v(:)
i=i+lmmaxo
end do
end if
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/writelat.f90 0000644 0000000 0000000 00000000132 13543334735 015002 x ustar 00 30 mtime=1569569245.299641517
30 atime=1569569241.542643917
30 ctime=1569569245.299641517
elk-6.3.2/src/writelat.f90 0000644 0025044 0025044 00000003245 13543334735 017055 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 writelat
use modmain
implicit none
open(50,file='LATTICE'//trim(filext),form='FORMATTED')
write(50,*)
write(50,'("+----------------------------+")')
write(50,'("| Real-space lattice vectors |")')
write(50,'("+----------------------------+")')
write(50,*)
write(50,'("vector a1 : ",3G18.10)') avec(:,1)
write(50,'("vector a2 : ",3G18.10)') avec(:,2)
write(50,'("vector a3 : ",3G18.10)') avec(:,3)
write(50,*)
write(50,'("Stored column-wise as a matrix :")')
write(50,'(3G18.10)') avec(1,:)
write(50,'(3G18.10)') avec(2,:)
write(50,'(3G18.10)') avec(3,:)
write(50,*)
write(50,'("Inverse of matrix :")')
write(50,'(3G18.10)') ainv(1,:)
write(50,'(3G18.10)') ainv(2,:)
write(50,'(3G18.10)') ainv(3,:)
write(50,*)
write(50,'("Unit cell volume : ",G18.10)') omega
write(50,*)
write(50,*)
write(50,'("+----------------------------------+")')
write(50,'("| Reciprocal-space lattice vectors |")')
write(50,'("+----------------------------------+")')
write(50,*)
write(50,'("vector b1 : ",3G18.10)') bvec(:,1)
write(50,'("vector b2 : ",3G18.10)') bvec(:,2)
write(50,'("vector b3 : ",3G18.10)') bvec(:,3)
write(50,*)
write(50,'("Stored column-wise as a matrix :")')
write(50,'(3G18.10)') bvec(1,:)
write(50,'(3G18.10)') bvec(2,:)
write(50,'(3G18.10)') bvec(3,:)
write(50,*)
write(50,'("Inverse of matrix :")')
write(50,'(3G18.10)') binv(1,:)
write(50,'(3G18.10)') binv(2,:)
write(50,'(3G18.10)') binv(3,:)
write(50,*)
write(50,'("Brillouin zone volume : ",G18.10)') omegabz
close(50)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/mtdmin.f90 0000644 0000000 0000000 00000000132 13543334735 014437 x ustar 00 30 mtime=1569569245.304641514
30 atime=1569569241.546643914
30 ctime=1569569245.304641514
elk-6.3.2/src/mtdmin.f90 0000644 0025044 0025044 00000003251 13543334735 016507 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.
!BOP
! !ROUTINE: mtdmin
! !INTERFACE:
subroutine mtdmin(is,js,dmin)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! is, js : species numbers (out,integer)
! dmin : minimum distance between muffin-tin surfaces (out,real)
! !DESCRIPTION:
! Finds the atomic species pair for which the distance between the muffin-tin
! surfaces is a minimum. This distance may be negative if the muffin-tins
! overlap.
!
! !REVISION HISTORY:
! Created October 2011 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(out) :: is,js
real(8), intent(out) :: dmin
! local variables
integer i1,i2,i3,ks,ka,ls,la
real(8) v1(3),v2(3),t1,t2,t3
is=1
js=1
dmin=1.d6
do i1=-1,1
do i2=-1,1
do i3=-1,1
v1(:)=dble(i1)*avec(:,1)+dble(i2)*avec(:,2)+dble(i3)*avec(:,3)
do ks=1,nspecies
do ka=1,natoms(ks)
v2(:)=v1(:)+atposc(:,ka,ks)
do ls=1,nspecies
t1=rmt(ks)+rmt(ls)
do la=1,natoms(ls)
if ((i1.ne.0).or.(i2.ne.0).or.(i3.ne.0).or.(ks.ne.ls).or. &
(ka.ne.la)) then
t2=sqrt((v2(1)-atposc(1,la,ls))**2 &
+(v2(2)-atposc(2,la,ls))**2 &
+(v2(3)-atposc(3,la,ls))**2)
t3=t2-t1
if (t3.lt.dmin-epslat) then
is=ks
js=ls
dmin=t3
end if
end if
end do
end do
end do
end do
end do
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/atpstep.f90 0000644 0000000 0000000 00000000132 13543334735 014627 x ustar 00 30 mtime=1569569245.308641511
30 atime=1569569241.551643911
30 ctime=1569569245.308641511
elk-6.3.2/src/atpstep.f90 0000644 0025044 0025044 00000003517 13543334735 016704 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: atpstep
! !INTERFACE:
subroutine atpstep
! !USES:
use modmain
use modmpi
! !DESCRIPTION:
! Makes a geometry optimisation step and updates the current atomic positions
! according to the force on each atom. If ${\bf r}_{ij}^m$ is the position and
! ${\bf F}_{ij}^m$ is the force acting on it for atom $j$ of species $i$ and
! after time step $m$, then the new position is calculated by
! $$ {\bf r}_{ij}^{m+1}={\bf r}_{ij}^m+\tau_{ij}^m\left({\bf F}_{ij}^m
! +{\bf F}_{ij}^{m-1}\right), $$
! where $\tau_{ij}^m$ is a parameter governing the size of the displacement.
! If ${\bf F}_{ij}^m\cdot{\bf F}_{ij}^{m-1}>0$ then $\tau_{ij}^m$ is
! increased, otherwise it is decreased.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ia,ias,n
real(8) t1
do is=1,nspecies
do ia=1,natoms(is)
ias=idxas(ia,is)
! compute the dot-product between the current and previous total force
t1=dot_product(forcetot(:,ias),forcetotp(:,ias))
! if the force is in the same direction then increase step size parameter
if (t1.gt.0.d0) then
tauatp(ias)=tauatp(ias)+tau0atp
else
tauatp(ias)=tau0atp
end if
! make atomic position step
atposc(:,ia,is)=atposc(:,ia,is)+tauatp(ias)*(forcetot(:,ias) &
+forcetotp(:,ias))
end do
end do
! each MPI process should have identical atomic positions
n=3*maxatoms*maxspecies
call mpi_bcast(atposc,n,mpi_double_precision,0,mpicom,ierror)
do is=1,nspecies
do ia=1,natoms(is)
! compute the lattice coordinates of the atomic positions
call r3mv(ainv,atposc(:,ia,is),atposl(:,ia,is))
end do
end do
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/potcoul.f90 0000644 0000000 0000000 00000000132 13543334735 014634 x ustar 00 30 mtime=1569569245.313641508
30 atime=1569569241.555643908
30 ctime=1569569245.313641508
elk-6.3.2/src/potcoul.f90 0000644 0025044 0025044 00000004676 13543334735 016720 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: potcoul
! !INTERFACE:
subroutine potcoul
! !USES:
use modmain
use modomp
! !DESCRIPTION:
! Calculates the Coulomb potential of the real charge density stored in the
! global variables {\tt rhomt} and {\tt rhoir} by solving Poisson's equation.
! These variables are coverted to complex representations and passed to the
! routine {\tt zpotcoul}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ias,nthd
integer nr,nri,ir,i
! allocatable arrays
complex(8), allocatable :: zrhomt(:,:),zrhoir(:)
complex(8), allocatable :: zvclmt(:,:),zvclir(:)
allocate(zrhomt(npmtmax,natmtot))
! convert real muffin-tin charge density to complex spherical harmonic expansion
call holdthd(natmtot,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(is) &
!$OMP NUM_THREADS(nthd)
do ias=1,natmtot
is=idxis(ias)
call rtozfmt(nrmt(is),nrmti(is),rhomt(:,ias),zrhomt(:,ias))
end do
!$OMP END PARALLEL DO
call freethd(nthd)
! solve the complex Poisson's equation in the muffin-tins
allocate(zvclmt(npmtmax,natmtot))
call genzvclmt(nrmt,nrmti,nrmtmax,rlmt,wprmt,npmtmax,zrhomt,zvclmt)
deallocate(zrhomt)
! add the nuclear monopole potentials
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
i=1
do ir=1,nri
zvclmt(i,ias)=zvclmt(i,ias)+vcln(ir,is)
i=i+lmmaxi
end do
do ir=nri+1,nr
zvclmt(i,ias)=zvclmt(i,ias)+vcln(ir,is)
i=i+lmmaxo
end do
end do
! store real interstitial charge density in complex array
allocate(zrhoir(ngtot))
zrhoir(:)=rhoir(:)
! solve Poisson's equation in the entire unit cell
allocate(zvclir(ngtot))
call zpotcoul(nrmt,nrmti,npmt,npmti,nrmtmax,rlmt,ngridg,igfft,ngvec,gc,gclg, &
ngvec,jlgrmt,ylmg,sfacg,zrhoir,npmtmax,zvclmt,zvclir)
! convert complex muffin-tin potential to real spherical harmonic expansion
call holdthd(natmtot,nthd)
!$OMP PARALLEL DO DEFAULT(SHARED) &
!$OMP PRIVATE(is) &
!$OMP NUM_THREADS(nthd)
do ias=1,natmtot
is=idxis(ias)
call ztorfmt(nrmt(is),nrmti(is),zvclmt(:,ias),vclmt(:,ias))
end do
!$OMP END PARALLEL DO
call freethd(nthd)
! store complex interstitial potential in real array
vclir(:)=dble(zvclir(:))
deallocate(zrhoir,zvclmt,zvclir)
! apply constant electric field if required
if (tefield) call potefield
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/zfmtconj.f90 0000644 0000000 0000000 00000000132 13543334735 015001 x ustar 00 30 mtime=1569569245.317641505
30 atime=1569569241.560643905
30 ctime=1569569245.317641505
elk-6.3.2/src/zfmtconj.f90 0000644 0025044 0025044 00000001143 13543334735 017047 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 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 zfmtconj(nr,nri,np,zfmt)
use modmain
implicit none
! arguments
integer, intent(in) :: nr,nri,np
complex(8), intent(inout) :: zfmt(np)
! local variables
integer ir,i
! automatic arrays
complex(8) zfmt1(np)
call zcopy(np,zfmt,1,zfmt1,1)
i=1
do ir=1,nri
call zflmconj(lmaxi,zfmt1(i),zfmt(i))
i=i+lmmaxi
end do
do ir=nri+1,nr
call zflmconj(lmaxo,zfmt1(i),zfmt(i))
i=i+lmmaxo
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/symrfmt.f90 0000644 0000000 0000000 00000000132 13543334735 014650 x ustar 00 30 mtime=1569569245.321641503
30 atime=1569569241.565643902
30 ctime=1569569245.321641503
elk-6.3.2/src/symrfmt.f90 0000644 0025044 0025044 00000003550 13543334735 016722 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 symrfmt(nr,nri,np,ld,rfmt)
use modmain
implicit none
! arguments
integer, intent(in) :: nr(nspecies),nri(nspecies),np(nspecies)
integer, intent(in) :: ld
real(8), intent(inout) :: rfmt(ld,natmtot)
! local variables
integer is,ia,ja,ias,jas
integer isym,lspl
real(8) t0
! automatic arrays
logical done(natmmax)
! allocatable arrays
real(8), allocatable :: rfmt1(:,:),rfmt2(:)
allocate(rfmt1(ld,natmmax),rfmt2(ld))
t0=1.d0/dble(nsymcrys)
do is=1,nspecies
! make a copy of the input function
do ia=1,natoms(is)
ias=idxas(ia,is)
call dcopy(np(is),rfmt(:,ias),1,rfmt1(:,ia),1)
end do
done(:)=.false.
! loop over atoms
do ia=1,natoms(is)
if (done(ia)) cycle
ias=idxas(ia,is)
rfmt(1:np(is),ias)=0.d0
! loop over crystal symmetries
do isym=1,nsymcrys
! index to spatial rotation lattice symmetry
lspl=lsplsymc(isym)
! equivalent atom index (symmetry rotates atom ja into atom ia)
ja=ieqatom(ia,is,isym)
! apply the rotation to the muffin-tin function
call rotrfmt(symlatc(:,:,lspl),nr(is),nri(is),rfmt1(:,ja),rfmt2)
! accumulate in original function array
rfmt(1:np(is),ias)=rfmt(1:np(is),ias)+rfmt2(1:np(is))
end do
! normalise
call dscal(np(is),t0,rfmt(:,ias),1)
done(ia)=.true.
! rotate into equivalent atoms
do isym=1,nsymcrys
ja=ieqatom(ia,is,isym)
if (done(ja)) cycle
jas=idxas(ja,is)
! inverse symmetry (which rotates atom ia into atom ja)
lspl=isymlat(lsplsymc(isym))
! rotate symmetrised function into equivalent muffin-tin
call rotrfmt(symlatc(:,:,lspl),nr(is),nri(is),rfmt(:,ias),rfmt(:,jas))
done(ja)=.true.
end do
end do
end do
deallocate(rfmt1,rfmt2)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/putpmat.f90 0000644 0000000 0000000 00000000126 13543334735 014644 x ustar 00 28 mtime=1569569245.3266415
30 atime=1569569241.569643899
28 ctime=1569569245.3266415
elk-6.3.2/src/putpmat.f90 0000644 0025044 0025044 00000003662 13543334735 016717 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2014 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 putpmat(ik)
use modmain
use modmpi
implicit none
! arguments
integer, intent(in) :: ik
! local variables
integer ist,ispn,recl,i
! automatic arrays
integer idx(nstsv)
! allocatable arrays
complex(8), allocatable :: apwalm(:,:,:,:,:),evecfv(:,:,:),evecsv(:,:)
complex(8), allocatable :: wfmt(:,:,:,:),wfgk(:,:,:),pmat(:,:,:)
! index to all states
do ist=1,nstsv
idx(ist)=ist
end do
allocate(evecfv(nmatmax,nstfv,nspnfv),evecsv(nstsv,nstsv))
! get the eigenvectors from file
call getevecfv(filext,ik,vkl(:,ik),vgkl(:,:,:,ik),evecfv)
call getevecsv(filext,ik,vkl(:,ik),evecsv)
! find the matching coefficients
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
do ispn=1,nspnfv
call match(ngk(ispn,ik),vgkc(:,:,ispn,ik),gkc(:,ispn,ik), &
sfacgk(:,:,ispn,ik),apwalm(:,:,:,:,ispn))
end do
! calculate the wavefunctions for all states
allocate(wfmt(npcmtmax,natmtot,nspinor,nstsv),wfgk(ngkmax,nspinor,nstsv))
call genwfsv(.true.,.true.,nstsv,idx,ngridg,igfft,ngk(:,ik),igkig(:,:,ik), &
apwalm,evecfv,evecsv,wfmt,ngkmax,wfgk)
deallocate(evecfv,evecsv,apwalm)
! calculate the momentum matrix elements
allocate(pmat(nstsv,nstsv,3))
call genpmatk(ngk(:,ik),igkig(:,:,ik),vgkc(:,:,:,ik),wfmt,wfgk,pmat)
deallocate(wfmt,wfgk)
! determine the record length
inquire(iolength=recl) vkl(:,1),nstsv,pmat
! write the matrix elements in the second-variational basis
!$OMP CRITICAL(u150)
do i=1,2
open(150,file='PMAT.OUT',form='UNFORMATTED',access='DIRECT',recl=recl,err=10)
write(150,rec=ik,err=10) vkl(:,ik),nstsv,pmat
close(150)
exit
10 continue
if (i.eq.2) then
write(*,*)
write(*,'("Error(putpmat): unable to write to PMAT.OUT")')
write(*,*)
stop
end if
close(150)
end do
!$OMP END CRITICAL(u150)
deallocate(pmat)
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/eveqnz.f90 0000644 0000000 0000000 00000000132 13543334735 014457 x ustar 00 30 mtime=1569569245.330641497
30 atime=1569569241.574643896
30 ctime=1569569245.330641497
elk-6.3.2/src/eveqnz.f90 0000644 0025044 0025044 00000003367 13543334735 016537 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 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 eveqnz(n,ld,a,w)
use modmain
use modomp
implicit none
! arguments
integer, intent(in) :: n,ld
complex(8), intent(inout) :: a(ld,n)
real(8), intent(out) :: w(n)
! local variables
integer liwork,lrwork
integer lwork,info,nthd
! allocatable arrays
integer, allocatable :: iwork(:)
real(8), allocatable :: rwork(:)
complex(8), allocatable :: work(:)
select case(evtype)
case(0)
! use the LAPACK routine zheev
lwork=2*n
allocate(rwork(3*n),work(lwork))
! enable MKL parallelism
call holdthd(maxthdmkl,nthd)
call mkl_set_num_threads(nthd)
call zheev('V','U',n,a,ld,w,work,lwork,rwork,info)
call freethd(nthd)
call mkl_set_num_threads(1)
if (info.ne.0) then
write(*,*)
write(*,'("Error(eveqnz): diagonalisation failed")')
write(*,'(" ZHEEV returned INFO = ",I8)') info
write(*,*)
stop
end if
deallocate(rwork,work)
case(1)
! use the divide-and-conquer LAPACK routine zheevd
liwork=5*n+3
lrwork=2*n**2+5*n+1
lwork=n**2+2*n
allocate(iwork(liwork),rwork(lrwork),work(lwork))
! enable MKL parallelism
call holdthd(maxthdmkl,nthd)
call mkl_set_num_threads(nthd)
call zheevd('V','U',n,a,ld,w,work,lwork,rwork,lrwork,iwork,liwork,info)
call freethd(nthd)
call mkl_set_num_threads(1)
if (info.ne.0) then
write(*,*)
write(*,'("Error(eveqnz): diagonalisation failed")')
write(*,'(" ZHEEVD returned INFO = ",I8)') info
write(*,*)
stop
end if
deallocate(iwork,rwork,work)
case default
write(*,*)
write(*,'("Error(eveqnz): evtype not defined : ",I8)') evtype
write(*,*)
stop
end select
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/olpalo.f90 0000644 0000000 0000000 00000000132 13543334735 014435 x ustar 00 30 mtime=1569569245.334641495
30 atime=1569569241.578643894
30 ctime=1569569245.334641495
elk-6.3.2/src/olpalo.f90 0000644 0025044 0025044 00000001417 13543334735 016507 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 olpalo(ias,ngp,apwalm,ld,o)
use modmain
implicit none
! arguments
integer, intent(in) :: ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: o(*)
! local variables
integer is,ilo,io
integer l,m,lm,i,j,k
is=idxis(ias)
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do m=-l,l
lm=idxlm(l,m)
j=ngp+idxlo(lm,ilo,ias)
k=(j-1)*ld
do i=1,ngp
k=k+1
do io=1,apword(l,is)
o(k)=o(k)+conjg(apwalm(i,io,lm))*oalo(io,ilo,ias)
end do
end do
end do
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/checkfsm.f90 0000644 0000000 0000000 00000000132 13543334735 014732 x ustar 00 30 mtime=1569569245.339641491
30 atime=1569569241.582643891
30 ctime=1569569245.339641491
elk-6.3.2/src/checkfsm.f90 0000644 0025044 0025044 00000003047 13543334735 017005 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.
subroutine checkfsm
use modmain
implicit none
! local variables
integer isym,lspn
integer is,ia,ja
real(8) sc(3,3),v(3),t1
if (fsmtype.eq.0) return
do isym=1,nsymcrys
lspn=lspnsymc(isym)
! proper rotation matrix in Cartesian coordinates
sc(:,:)=dble(symlatd(lspn))*symlatc(:,:,lspn)
! check invariance of global moment
if ((abs(fsmtype).eq.1).or.(abs(fsmtype).eq.3)) then
call r3mv(sc,momfix,v)
t1=sum(abs(momfix(:)-v(:)))
if (t1.gt.epslat) then
write(*,*)
write(*,'("Error(checkfsm): momfix not invariant under symmetry group")')
write(*,*)
stop
end if
end if
! check invariance of muffin-tin moments
if ((abs(fsmtype).eq.2).or.(abs(fsmtype).eq.3)) then
do is=1,nspecies
do ia=1,natoms(is)
! if any component is >= 1000 then do not fix the moment
t1=sum(abs(mommtfix(:,ia,is)))
if (t1.ge.1000.d0) cycle
! equivalent atom
ja=ieqatom(ia,is,isym)
call r3mv(sc,mommtfix(:,ja,is),v)
t1=sum(abs(mommtfix(:,ia,is)-v(:)))
if (t1.gt.epslat) then
write(*,*)
write(*,'("Error(checkfsm): mommtfix not invariant under symmetry &
&group")')
write(*,'(" for species ",I4)') is
write(*,'(" and equivalent atoms ",2I4)') ia,ja
write(*,*)
stop
end if
end do
end do
end if
end do
return
end subroutine
elk-6.3.2/src/PaxHeaders.21352/rhoplot.f90 0000644 0000000 0000000 00000000132 13543334735 014636 x ustar 00 30 mtime=1569569245.343641489
30 atime=1569569241.586643888
30 ctime=1569569245.343641489
elk-6.3.2/src/rhoplot.f90 0000644 0025044 0025044 00000002461 13543334735 016710 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: rhoplot
! !INTERFACE:
subroutine rhoplot
! !USES:
use modmain
! !DESCRIPTION:
! Outputs the charge density, read in from {\tt STATE.OUT}, for 1D, 2D or 3D
! plotting.
!
! !REVISION HISTORY:
! Created June 2003 (JKD)
!EOP
!BOC
implicit none
! initialise universal variables
call init0
! read density from file
call readstate
! write the density plot to file
select case(task)
case(31)
open(50,file='RHO1D.OUT',form='FORMATTED')
open(51,file='RHOLINES.OUT',form='FORMATTED')
call plot1d(50,51,1,rhomt,rhoir)
close(50)
close(51)
write(*,*)
write(*,'("Info(rhoplot):")')
write(*,'(" 1D density plot written to RHO1D.OUT")')
write(*,'(" vertex location lines written to RHOLINES.OUT")')
case(32)
open(50,file='RHO2D.OUT',form='FORMATTED')
call plot2d(.false.,50,1,rhomt,rhoir)
close(50)
write(*,*)
write(*,'("Info(rhoplot): 2D density plot written to RHO2D.OUT")')
case(33)
open(50,file='RHO3D.OUT',form='FORMATTED')
call plot3d(50,1,rhomt,rhoir)
close(50)
write(*,*)
write(*,'("Info(rhoplot): 3D density plot written to RHO3D.OUT")')
end select
return
end subroutine
!EOC
elk-6.3.2/src/PaxHeaders.21352/potnucl.f90 0000644 0000000 0000000 00000000132 13543334735 014633 x ustar 00 30 mtime=1569569245.348641486
30 atime=1569569241.591643885
30 ctime=1569569245.348641486
elk-6.3.2/src/potnucl.f90 0000644 0025044 0025044 00000003145 13543334735 016705 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