mirror of https://gitlab.com/QEF/q-e.git
3955 lines
126 KiB
Fortran
3955 lines
126 KiB
Fortran
!
|
|
! Copyright (C) 2002-2005 FPMD-CPV groups
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
|
|
#include "f_defs.h"
|
|
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE atomic_wfc( eigr, n_atomic_wfc, wfc )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Compute atomic wavefunctions in G-space
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart, g, gx
|
|
USE ions_base, ONLY: nsp, na, nat
|
|
USE cell_base, ONLY: tpiba
|
|
USE atom, ONLY: nchi, lchi, mesh, r, chi, rab
|
|
!
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(in) :: n_atomic_wfc
|
|
COMPLEX(DP), INTENT(in) :: eigr( ngw, nat )
|
|
COMPLEX(DP), INTENT(out):: wfc( ngw, n_atomic_wfc )
|
|
!
|
|
INTEGER :: natwfc, ndm, is, ia, ir, nb, l, m, lm, i, lmax_wfc, isa
|
|
REAL(DP), ALLOCATABLE :: ylm(:,:), q(:), jl(:), vchi(:), chiq(:)
|
|
!
|
|
! calculate max angular momentum required in wavefunctions
|
|
!
|
|
lmax_wfc=-1
|
|
DO is = 1,nsp
|
|
DO nb = 1, nchi(is)
|
|
lmax_wfc = MAX (lmax_wfc, lchi (nb, is) )
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
ALLOCATE(ylm(ngw,(lmax_wfc+1)**2))
|
|
!
|
|
CALL ylmr2 ((lmax_wfc+1)**2, ngw, gx, g, ylm)
|
|
ndm = MAXVAL(mesh(1:nsp))
|
|
!
|
|
ALLOCATE(jl(ndm), vchi(ndm))
|
|
ALLOCATE(q(ngw), chiq(ngw))
|
|
!
|
|
DO i=1,ngw
|
|
q(i) = SQRT(g(i))*tpiba
|
|
END DO
|
|
!
|
|
natwfc=0
|
|
isa = 0
|
|
DO is=1,nsp
|
|
!
|
|
! radial fourier transform of the chi functions
|
|
! NOTA BENE: chi is r times the radial part of the atomic wavefunction
|
|
!
|
|
DO nb = 1,nchi(is)
|
|
l = lchi(nb,is)
|
|
DO i=1,ngw
|
|
CALL sph_bes (mesh(is), r(1,is), q(i), l, jl)
|
|
DO ir=1,mesh(is)
|
|
vchi(ir) = chi(ir,nb,is)*r(ir,is)*jl(ir)
|
|
ENDDO
|
|
CALL simpson_cp90(mesh(is),vchi,rab(1,is),chiq(i))
|
|
ENDDO
|
|
!
|
|
! multiply by angular part and structure factor
|
|
! NOTA BENE: the factor i^l MUST be present!!!
|
|
!
|
|
DO m = 1,2*l+1
|
|
lm = l**2 + m
|
|
DO ia = 1 + isa, na(is) + isa
|
|
natwfc = natwfc + 1
|
|
wfc(:,natwfc) = (0.d0,1.d0)**l * eigr(:,ia)* ylm(:,lm)*chiq(:)
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
isa = isa + na(is)
|
|
ENDDO
|
|
!
|
|
IF (natwfc.NE.n_atomic_wfc) &
|
|
& CALL errore('atomic_wfc','unexpected error',natwfc)
|
|
!
|
|
DEALLOCATE(q, chiq, vchi, jl, ylm)
|
|
!
|
|
RETURN
|
|
END SUBROUTINE atomic_wfc
|
|
!
|
|
|
|
!-----------------------------------------------------------------------
|
|
FUNCTION n_atom_wfc_x( )
|
|
!----------------------------------------------------------------------------
|
|
!
|
|
! ... Find max number of bands needed
|
|
!
|
|
USE atom, ONLY : nchi, lchi, oc
|
|
USE ions_base, ONLY : na, nsp
|
|
USE kinds, ONLY : DP
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: n_atom_wfc_x
|
|
INTEGER :: is, n
|
|
!
|
|
n_atom_wfc_x = 0
|
|
!
|
|
DO is = 1, nsp
|
|
!
|
|
DO n = 1, nchi( is )
|
|
!
|
|
IF ( oc( n, is ) >= 0.D0 ) THEN
|
|
!
|
|
n_atom_wfc_x = n_atom_wfc_x + na(is) * ( 2 * lchi( n, is ) + 1 )
|
|
!
|
|
END IF
|
|
!
|
|
END DO
|
|
!
|
|
END DO
|
|
!
|
|
RETURN
|
|
END FUNCTION
|
|
|
|
!
|
|
|
|
!-----------------------------------------------------------------------
|
|
FUNCTION cscnorm( bec, nkbx, cp, ngwx, i, n )
|
|
!-----------------------------------------------------------------------
|
|
! requires in input the updated bec(i)
|
|
!
|
|
USE ions_base, ONLY: na
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE cvan, ONLY: ish, nvb
|
|
USE uspp_param, ONLY: nh
|
|
USE uspp, ONLY: qq
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE kinds, ONLY: DP
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: i, n
|
|
INTEGER, INTENT(IN) :: ngwx, nkbx
|
|
REAL(DP) :: bec( nkbx, n )
|
|
COMPLEX(DP) :: cp( ngwx, n )
|
|
!
|
|
REAL(DP) :: cscnorm
|
|
!
|
|
INTEGER ig, is, iv, jv, ia, inl, jnl
|
|
REAL(DP) rsum
|
|
REAL(DP), ALLOCATABLE:: temp(:)
|
|
!
|
|
!
|
|
ALLOCATE(temp(ngw))
|
|
DO ig=1,ngw
|
|
temp(ig)=DBLE(CONJG(cp(ig,i))*cp(ig,i))
|
|
END DO
|
|
rsum=2.d0*SUM(temp)
|
|
IF (gstart == 2) rsum=rsum-temp(1)
|
|
|
|
CALL mp_sum( rsum, intra_image_comm )
|
|
|
|
DEALLOCATE(temp)
|
|
!
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
IF(ABS(qq(iv,jv,is)).GT.1.e-5) THEN
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
rsum = rsum + &
|
|
& qq(iv,jv,is)*bec(inl,i)*bec(jnl,i)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
cscnorm=SQRT(rsum)
|
|
!
|
|
RETURN
|
|
END FUNCTION cscnorm
|
|
!
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE denlcc( nnr, nspin, vxcr, sfac, drhocg, dcc )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! derivative of non linear core correction exchange energy wrt cell
|
|
! parameters h
|
|
! Output in dcc
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE ions_base, ONLY: nsp
|
|
USE reciprocal_vectors, ONLY: gstart, gx, ngs, g, ngm
|
|
USE recvecs_indexes, ONLY: np
|
|
USE cell_base, ONLY: omega, ainv, tpiba2
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE atom, ONLY: nlcc
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3, nr1x, nr2x, nr3x
|
|
USE cp_interfaces, ONLY: fwfft
|
|
|
|
IMPLICIT NONE
|
|
|
|
! input
|
|
|
|
INTEGER, INTENT(IN) :: nnr, nspin
|
|
REAL(DP) :: vxcr( nnr, nspin )
|
|
COMPLEX(DP) :: sfac( ngs, nsp )
|
|
REAL(DP) :: drhocg( ngm, nsp )
|
|
|
|
! output
|
|
|
|
REAL(DP), INTENT(OUT) :: dcc(3,3)
|
|
|
|
! local
|
|
|
|
INTEGER :: i, j, ig, is
|
|
COMPLEX(DP) :: srhoc
|
|
REAL(DP) :: vxcc
|
|
!
|
|
COMPLEX(DP), ALLOCATABLE :: vxc( : )
|
|
!
|
|
dcc = 0.0d0
|
|
!
|
|
ALLOCATE( vxc( nnr ) )
|
|
!
|
|
vxc(:) = vxcr(:,1)
|
|
!
|
|
IF( nspin > 1 ) vxc(:) = vxc(:) + vxcr(:,2)
|
|
!
|
|
CALL fwfft( 'Dense', vxc, nr1, nr2, nr3, nr1x, nr2x, nr3x )
|
|
!
|
|
DO i=1,3
|
|
DO j=1,3
|
|
DO ig = gstart, ngs
|
|
srhoc = 0.0d0
|
|
DO is = 1, nsp
|
|
IF( nlcc( is ) ) srhoc = srhoc + sfac( ig, is ) * drhocg( ig, is )
|
|
ENDDO
|
|
vxcc = DBLE( CONJG( vxc( np( ig ) ) ) * srhoc ) / SQRT( g( ig ) * tpiba2 )
|
|
dcc(i,j) = dcc(i,j) + vxcc * &
|
|
& 2.d0 * tpiba2 * gx(i,ig) * &
|
|
& (gx(1,ig)*ainv(j,1) + &
|
|
& gx(2,ig)*ainv(j,2) + &
|
|
& gx(3,ig)*ainv(j,3) )
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
|
|
DEALLOCATE( vxc )
|
|
|
|
dcc = dcc * omega
|
|
|
|
CALL mp_sum( dcc( 1:3, 1:3 ), intra_image_comm )
|
|
|
|
RETURN
|
|
END SUBROUTINE denlcc
|
|
|
|
|
|
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE dotcsc( eigr, cp, ngw, n )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE ions_base, ONLY: na, nsp, nat
|
|
USE io_global, ONLY: stdout
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE cvan, ONLY: ish, nvb
|
|
USE uspp, ONLY: nkb, qq
|
|
USE uspp_param, ONLY: nh
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: ngw, n
|
|
COMPLEX(DP) :: eigr(ngw,nat), cp(ngw,n)
|
|
! local variables
|
|
REAL(DP) rsum, csc(n) ! automatic array
|
|
COMPLEX(DP) temp(ngw) ! automatic array
|
|
|
|
REAL(DP), ALLOCATABLE:: becp(:,:)
|
|
INTEGER i,kmax,nnn,k,ig,is,ia,iv,jv,inl,jnl
|
|
!
|
|
ALLOCATE(becp(nkb,n))
|
|
!
|
|
! < beta | phi > is real. only the i lowest:
|
|
!
|
|
nnn = MIN( 12, n )
|
|
|
|
DO i = nnn, 1, -1
|
|
kmax = i
|
|
CALL nlsm1(i,1,nvb,eigr,cp,becp)
|
|
!
|
|
DO k=1,kmax
|
|
DO ig=1,ngw
|
|
temp(ig)=CONJG(cp(ig,k))*cp(ig,i)
|
|
END DO
|
|
csc(k)=2.d0*DBLE(SUM(temp))
|
|
IF (gstart == 2) csc(k)=csc(k)-DBLE(temp(1))
|
|
END DO
|
|
|
|
CALL mp_sum( csc( 1:kmax ), intra_image_comm )
|
|
|
|
DO k=1,kmax
|
|
rsum=0.d0
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
rsum = rsum + &
|
|
& qq(iv,jv,is)*becp(inl,i)*becp(jnl,k)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
csc(k)=csc(k)+rsum
|
|
END DO
|
|
!
|
|
WRITE( stdout,'("dotcsc =",12f18.15)') (csc(k),k=1,i)
|
|
!
|
|
END DO
|
|
WRITE( stdout,*)
|
|
!
|
|
DEALLOCATE(becp)
|
|
!
|
|
RETURN
|
|
END SUBROUTINE dotcsc
|
|
|
|
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE dotcsv( csv, eigr, c, v, ngw )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE ions_base, ONLY: na, nsp, nat
|
|
USE io_global, ONLY: stdout
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE cvan, ONLY: ish, nvb
|
|
USE uspp, ONLY: nkb, qq
|
|
USE uspp_param, ONLY: nh
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: ngw
|
|
COMPLEX(DP) :: eigr(ngw,nat), c(ngw), v(ngw)
|
|
REAL(DP), INTENT(OUT) :: csv
|
|
|
|
! local variables
|
|
COMPLEX(DP) temp(ngw) ! automatic array
|
|
|
|
REAL(DP), ALLOCATABLE :: bec(:), bev(:)
|
|
INTEGER ig,is,ia,iv,jv,inl,jnl
|
|
!
|
|
ALLOCATE(bec(nkb))
|
|
ALLOCATE(bev(nkb))
|
|
!
|
|
! < beta | c > is real. only the i lowest:
|
|
!
|
|
CALL nlsm1(1,1,nvb,eigr,c,bec)
|
|
CALL nlsm1(1,1,nvb,eigr,v,bev)
|
|
!
|
|
DO ig=1,ngw
|
|
temp(ig)=CONJG(c(ig))*v(ig)
|
|
END DO
|
|
csv = 2.0d0 * DBLE(SUM(temp))
|
|
IF (gstart == 2) csv = csv - DBLE(temp(1))
|
|
|
|
CALL mp_sum( csv, intra_image_comm )
|
|
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
csv = csv + qq(iv,jv,is)*bec(inl)*bev(jnl)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
DEALLOCATE(bec)
|
|
DEALLOCATE(bev)
|
|
!
|
|
RETURN
|
|
END SUBROUTINE dotcsv
|
|
|
|
|
|
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE drhov(irb,eigrb,rhovan,rhog,rhor)
|
|
!-----------------------------------------------------------------------
|
|
! this routine calculates arrays drhog drhor, derivatives wrt h of:
|
|
!
|
|
! n_v(g) = sum_i,ij rho_i,ij q_i,ji(g) e^-ig.r_i
|
|
!
|
|
! Same logic as in routine rhov.
|
|
! On input rhor and rhog must contain the smooth part only !!!
|
|
! Output in module derho (drhor, drhog)
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE control_flags, ONLY: iprint
|
|
USE ions_base, ONLY: na, nsp, nat
|
|
USE cvan, ONLY: nvb
|
|
USE uspp_param, ONLY: nhm, nh
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3, &
|
|
nr1x, nr2x, nr3x, nnr => nnrx
|
|
USE electrons_base, ONLY: nspin
|
|
USE gvecb, ONLY: ngb, npb, nmb
|
|
USE gvecp, ONLY: ng => ngm
|
|
USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, &
|
|
nr1bx, nr2bx, nr3bx, nnrb => nnrbx
|
|
USE cell_base, ONLY: ainv
|
|
USE qgb_mod, ONLY: qgb
|
|
USE cdvan, ONLY: drhovan
|
|
USE derho, ONLY: drhor, drhog
|
|
USE dqgb_mod, ONLY: dqgb
|
|
USE recvecs_indexes, ONLY: nm, np
|
|
USE cp_interfaces, ONLY: fwfft, invfft
|
|
USE fft_base, ONLY: dfftb
|
|
|
|
IMPLICIT NONE
|
|
! input
|
|
INTEGER, INTENT(in) :: irb(3,nat)
|
|
REAL(DP), INTENT(in):: rhor(nnr,nspin)
|
|
REAL(DP) :: rhovan(nhm*(nhm+1)/2,nat,nspin)
|
|
COMPLEX(DP), INTENT(in):: eigrb(ngb,nat), rhog(ng,nspin)
|
|
! local
|
|
INTEGER i, j, isup, isdw, nfft, ifft, iv, jv, ig, ijv, is, iss, &
|
|
& isa, ia, ir
|
|
REAL(DP) sum, dsum
|
|
COMPLEX(DP) fp, fm, ci
|
|
COMPLEX(DP), ALLOCATABLE :: v(:)
|
|
COMPLEX(DP), ALLOCATABLE:: dqgbt(:,:)
|
|
COMPLEX(DP), ALLOCATABLE :: qv(:)
|
|
!
|
|
!
|
|
DO j=1,3
|
|
DO i=1,3
|
|
DO iss=1,nspin
|
|
DO ir=1,nnr
|
|
drhor(ir,iss,i,j)=-rhor(ir,iss)*ainv(j,i)
|
|
END DO
|
|
DO ig=1,ng
|
|
drhog(ig,iss,i,j)=-rhog(ig,iss)*ainv(j,i)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
|
|
IF ( nvb == 0 ) RETURN
|
|
|
|
ALLOCATE( v( nnr ) )
|
|
ALLOCATE( qv( nnrb ) )
|
|
ALLOCATE( dqgbt( ngb, 2 ) )
|
|
|
|
ci =( 0.0d0, 1.0d0 )
|
|
|
|
IF( nspin == 1 ) THEN
|
|
!
|
|
! nspin=1 : two fft at a time, one per atom, if possible
|
|
!
|
|
DO i=1,3
|
|
DO j=1,3
|
|
|
|
v(:) = (0.d0, 0.d0)
|
|
|
|
iss=1
|
|
isa=1
|
|
|
|
DO is=1,nvb
|
|
#ifdef __PARA
|
|
DO ia=1,na(is)
|
|
nfft=1
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 15
|
|
#else
|
|
DO ia=1,na(is),2
|
|
nfft=2
|
|
#endif
|
|
dqgbt(:,:) = (0.d0, 0.d0)
|
|
IF (ia.EQ.na(is)) nfft=1
|
|
!
|
|
! nfft=2 if two ffts at the same time are performed
|
|
!
|
|
DO ifft=1,nfft
|
|
DO iv=1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
sum = rhovan(ijv,isa+ifft-1,iss)
|
|
dsum=drhovan(ijv,isa+ifft-1,iss,i,j)
|
|
IF(iv.NE.jv) THEN
|
|
sum =2.d0*sum
|
|
dsum=2.d0*dsum
|
|
ENDIF
|
|
DO ig=1,ngb
|
|
dqgbt(ig,ifft)=dqgbt(ig,ifft) + &
|
|
& (sum*dqgb(ig,ijv,is,i,j) + &
|
|
& dsum*qgb(ig,ijv,is) )
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! add structure factor
|
|
!
|
|
qv(:) = (0.d0, 0.d0)
|
|
IF(nfft.EQ.2) THEN
|
|
DO ig=1,ngb
|
|
qv(npb(ig)) = eigrb(ig,isa )*dqgbt(ig,1) &
|
|
& + ci* eigrb(ig,isa+1 )*dqgbt(ig,2)
|
|
qv(nmb(ig))= &
|
|
& CONJG(eigrb(ig,isa )*dqgbt(ig,1)) &
|
|
& + ci*CONJG(eigrb(ig,isa+1)*dqgbt(ig,2))
|
|
END DO
|
|
ELSE
|
|
DO ig=1,ngb
|
|
qv(npb(ig)) = eigrb(ig,isa)*dqgbt(ig,1)
|
|
qv(nmb(ig)) = &
|
|
& CONJG(eigrb(ig,isa)*dqgbt(ig,1))
|
|
END DO
|
|
ENDIF
|
|
!
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
!
|
|
! qv = US contribution in real space on box grid
|
|
! for atomic species is, real(qv)=atom ia, imag(qv)=atom ia+1
|
|
!
|
|
! add qv(r) to v(r), in real space on the dense grid
|
|
!
|
|
CALL box2grid( irb(1,isa), 1, qv, v )
|
|
IF (nfft.EQ.2) CALL box2grid(irb(1,isa+1),2,qv,v)
|
|
|
|
15 isa = isa + nfft
|
|
!
|
|
END DO
|
|
END DO
|
|
!
|
|
DO ir=1,nnr
|
|
drhor(ir,iss,i,j) = drhor(ir,iss,i,j) + DBLE(v(ir))
|
|
END DO
|
|
!
|
|
CALL fwfft( 'Dense', v, nr1, nr2, nr3, nr1x, nr2x, nr3x )
|
|
!
|
|
DO ig=1,ng
|
|
drhog(ig,iss,i,j) = drhog(ig,iss,i,j) + v(np(ig))
|
|
END DO
|
|
!
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
ELSE
|
|
!
|
|
! nspin=2: two fft at a time, one for spin up and one for spin down
|
|
!
|
|
isup=1
|
|
isdw=2
|
|
DO i=1,3
|
|
DO j=1,3
|
|
v(:) = (0.d0, 0.d0)
|
|
isa=1
|
|
DO is=1,nvb
|
|
DO ia=1,na(is)
|
|
#ifdef __PARA
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 25
|
|
#endif
|
|
DO iss=1,2
|
|
dqgbt(:,iss) = (0.d0, 0.d0)
|
|
DO iv= 1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
sum=rhovan(ijv,isa,iss)
|
|
dsum =drhovan(ijv,isa,iss,i,j)
|
|
IF(iv.NE.jv) THEN
|
|
sum =2.d0*sum
|
|
dsum=2.d0*dsum
|
|
ENDIF
|
|
DO ig=1,ngb
|
|
dqgbt(ig,iss)=dqgbt(ig,iss) + &
|
|
& (sum*dqgb(ig,ijv,is,i,j) + &
|
|
& dsum*qgb(ig,ijv,is))
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! add structure factor
|
|
!
|
|
qv(:) = (0.d0, 0.d0)
|
|
DO ig=1,ngb
|
|
qv(npb(ig))= eigrb(ig,isa)*dqgbt(ig,1) &
|
|
& + ci* eigrb(ig,isa)*dqgbt(ig,2)
|
|
qv(nmb(ig))= CONJG(eigrb(ig,isa)*dqgbt(ig,1)) &
|
|
& + ci*CONJG(eigrb(ig,isa)*dqgbt(ig,2))
|
|
END DO
|
|
!
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
!
|
|
! qv is the now the US augmentation charge for atomic species is
|
|
! and atom ia: real(qv)=spin up, imag(qv)=spin down
|
|
!
|
|
! add qv(r) to v(r), in real space on the dense grid
|
|
!
|
|
CALL box2grid2(irb(1,isa),qv,v)
|
|
!
|
|
25 isa = isa + 1
|
|
!
|
|
END DO
|
|
END DO
|
|
!
|
|
DO ir=1,nnr
|
|
drhor(ir,isup,i,j) = drhor(ir,isup,i,j) + DBLE(v(ir))
|
|
drhor(ir,isdw,i,j) = drhor(ir,isdw,i,j) +AIMAG(v(ir))
|
|
ENDDO
|
|
!
|
|
CALL fwfft('Dense', v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
|
|
DO ig=1,ng
|
|
fp=v(np(ig))+v(nm(ig))
|
|
fm=v(np(ig))-v(nm(ig))
|
|
drhog(ig,isup,i,j) = drhog(ig,isup,i,j) + &
|
|
& 0.5d0*CMPLX( DBLE(fp),AIMAG(fm))
|
|
drhog(ig,isdw,i,j) = drhog(ig,isdw,i,j) + &
|
|
& 0.5d0*CMPLX(AIMAG(fp),-DBLE(fm))
|
|
END DO
|
|
!
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
DEALLOCATE(dqgbt)
|
|
DEALLOCATE( v )
|
|
DEALLOCATE( qv )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE drhov
|
|
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
FUNCTION enkin( c, ngwx, f, n )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! calculation of kinetic energy term
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE constants, ONLY: pi, fpi
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE gvecw, ONLY: ggp
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE cell_base, ONLY: tpiba2
|
|
|
|
IMPLICIT NONE
|
|
|
|
REAL(DP) :: enkin
|
|
|
|
! input
|
|
|
|
INTEGER, INTENT(IN) :: ngwx, n
|
|
COMPLEX(DP), INTENT(IN) :: c( ngwx, n )
|
|
REAL(DP), INTENT(IN) :: f( n )
|
|
!
|
|
! local
|
|
|
|
INTEGER :: ig, i
|
|
REAL(DP) :: sk(n) ! automatic array
|
|
!
|
|
DO i=1,n
|
|
sk(i)=0.0d0
|
|
DO ig=gstart,ngw
|
|
sk(i)=sk(i)+DBLE(CONJG(c(ig,i))*c(ig,i))*ggp(ig)
|
|
END DO
|
|
END DO
|
|
|
|
CALL mp_sum( sk(1:n), intra_image_comm )
|
|
|
|
enkin=0.0d0
|
|
DO i=1,n
|
|
enkin=enkin+f(i)*sk(i)
|
|
END DO
|
|
|
|
! ... reciprocal-space vectors are in units of alat/(2 pi) so a
|
|
! ... multiplicative factor (2 pi/alat)**2 is required
|
|
|
|
enkin = enkin * tpiba2
|
|
!
|
|
RETURN
|
|
END FUNCTION enkin
|
|
!
|
|
!
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE force_ps(rhotemp,rhog,vtemp,ei1,ei2,ei3,fion1)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Contribution to ionic forces from local pseudopotential
|
|
!
|
|
USE kinds, ONLY: dp
|
|
USE constants, ONLY: pi, fpi
|
|
USE electrons_base, ONLY: nspin
|
|
USE gvecs, ONLY: ngs
|
|
USE gvecp, ONLY: ng => ngm
|
|
USE reciprocal_vectors, ONLY: gstart, gx, mill_l, g
|
|
USE cell_base, ONLY: omega, tpiba, tpiba2
|
|
USE ions_base, ONLY: nsp, na, nat
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3
|
|
USE local_pseudo, ONLY: vps, rhops
|
|
!
|
|
IMPLICIT NONE
|
|
! input
|
|
COMPLEX(DP) rhotemp(ng), rhog(ng,nspin), vtemp(ng), &
|
|
& ei1(-nr1:nr1,nat), &
|
|
& ei2(-nr2:nr2,nat), &
|
|
& ei3(-nr3:nr3,nat)
|
|
! output
|
|
REAL(DP) fion1(3,nat)
|
|
! local
|
|
INTEGER ig, is, isa, ism, ia, ix, iss, isup, isdw
|
|
INTEGER i, j, k
|
|
REAL(DP) wz
|
|
COMPLEX(DP) eigrx, vcgs, cnvg, cvn
|
|
!
|
|
! wz = factor for g.neq.0 because of c*(g)=c(-g)
|
|
!
|
|
wz=2.0d0
|
|
DO is=1,nsp
|
|
isa=0
|
|
DO ism=1,is-1
|
|
isa=isa+na(ism)
|
|
END DO
|
|
DO ia=1,na(is)
|
|
isa=isa+1
|
|
DO ix=1,3
|
|
IF(nspin.EQ.1)THEN
|
|
iss=1
|
|
IF (gstart == 2) vtemp(1)=0.0d0
|
|
DO ig=gstart,ngs
|
|
vcgs=CONJG(rhotemp(ig))*fpi/(tpiba2*g(ig))
|
|
cnvg=rhops(ig,is)*vcgs
|
|
cvn=vps(ig,is)*CONJG(rhog(ig,iss))
|
|
i = mill_l(1,ig)
|
|
j = mill_l(2,ig)
|
|
k = mill_l(3,ig)
|
|
eigrx=ei1(i,isa)*ei2(j,isa)*ei3(k,isa)
|
|
vtemp(ig)=eigrx*(cnvg+cvn)*CMPLX(0.d0,gx(ix,ig))
|
|
END DO
|
|
ELSE
|
|
isup=1
|
|
isdw=2
|
|
IF (gstart == 2) vtemp(1)=0.0d0
|
|
DO ig=gstart,ngs
|
|
vcgs=CONJG(rhotemp(ig))*fpi/(tpiba2*g(ig))
|
|
cnvg=rhops(ig,is)*vcgs
|
|
cvn=vps(ig,is)*CONJG(rhog(ig,isup) &
|
|
& +rhog(ig,isdw))
|
|
i = mill_l(1,ig)
|
|
j = mill_l(2,ig)
|
|
k = mill_l(3,ig)
|
|
eigrx=ei1(i,isa)*ei2(j,isa)*ei3(k,isa)
|
|
vtemp(ig)=eigrx*(cnvg+cvn)*CMPLX(0.d0,gx(ix,ig))
|
|
END DO
|
|
ENDIF
|
|
fion1(ix,isa) = fion1(ix,isa) + tpiba*omega* wz*DBLE(SUM(vtemp))
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
RETURN
|
|
END SUBROUTINE force_ps
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE gausin(eigr,cm)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! initialize wavefunctions with gaussians - edit to fit your system
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE ions_base, ONLY: na, nsp, nat
|
|
USE electrons_base, ONLY: n => nbsp
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gx, g
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX(DP) eigr(ngw,nat), cm(ngw,n)
|
|
REAL(DP) sigma, auxf
|
|
INTEGER nband, is, ia, ig, isa
|
|
!
|
|
sigma=12.0d0
|
|
nband=0
|
|
!!! do is=1,nsp
|
|
isa = 0
|
|
is=1
|
|
DO ia=1,na(is)
|
|
! s-like gaussians
|
|
nband=nband+1
|
|
DO ig=1,ngw
|
|
auxf=EXP(-g(ig)/sigma**2)
|
|
cm(ig,nband)=auxf*eigr(ig,ia+isa)
|
|
END DO
|
|
! px-like gaussians
|
|
nband=nband+1
|
|
DO ig=1,ngw
|
|
auxf=EXP(-g(ig)/sigma**2)
|
|
cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig)
|
|
END DO
|
|
! py-like gaussians
|
|
nband=nband+1
|
|
DO ig=1,ngw
|
|
auxf=EXP(-g(ig)/sigma**2)
|
|
cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(2,ig)
|
|
END DO
|
|
! pz-like gaussians
|
|
nband=nband+1
|
|
DO ig=1,ngw
|
|
auxf=EXP(-g(ig)/sigma**2)
|
|
cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(3,ig)
|
|
END DO
|
|
END DO
|
|
isa = isa + na(is)
|
|
is=2
|
|
DO ia=1,na(is)
|
|
! s-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)
|
|
! end do
|
|
! px-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig)
|
|
! end do
|
|
! py-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(2,ig)
|
|
! end do
|
|
! pz-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(3,ig)
|
|
! end do
|
|
! dxy-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig)*gx(2,ig)
|
|
! end do
|
|
! dxz-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(1,ig)*gx(3,ig)
|
|
! end do
|
|
! dxy-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)*gx(2,ig)*gx(3,ig)
|
|
! end do
|
|
! dx2-y2-like gaussians
|
|
! nband=nband+1
|
|
! do ig=1,ngw
|
|
! auxf=exp(-g(ig)/sigma**2)
|
|
! cm(ig,nband)=auxf*eigr(ig,ia+isa)* &
|
|
! & (gx(1,ig)**2-gx(2,ig)**2)
|
|
! end do
|
|
END DO
|
|
!!! end do
|
|
RETURN
|
|
END SUBROUTINE gausin
|
|
!
|
|
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE gracsc( bec, nkbx, betae, cp, ngwx, i, csc, n )
|
|
!-----------------------------------------------------------------------
|
|
! requires in input the updated bec(k) for k<i
|
|
! on output: bec(i) is recalculated
|
|
!
|
|
USE ions_base, ONLY: na
|
|
USE cvan, ONLY :nvb, ish
|
|
USE uspp, ONLY : nkb, nhsavb=>nkbus, qq
|
|
USE uspp_param, ONLY: nh
|
|
USE electrons_base, ONLY: ispin
|
|
USE gvecw, ONLY: ngw
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE kinds, ONLY: DP
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: i, nkbx, ngwx, n
|
|
COMPLEX(DP) :: betae( ngwx, nkb )
|
|
REAL(DP) :: bec( nkbx, n ), cp( 2, ngwx, n )
|
|
REAL(DP) :: csc( n )
|
|
INTEGER :: k, kmax,ig, is, iv, jv, ia, inl, jnl
|
|
REAL(DP) :: rsum
|
|
REAL(DP), ALLOCATABLE :: temp(:)
|
|
|
|
!
|
|
! calculate csc(k)=<cp(i)|cp(k)>, k<i
|
|
!
|
|
ALLOCATE( temp( ngw ) )
|
|
|
|
kmax = i - 1
|
|
|
|
DO k = 1, kmax
|
|
csc(k) = 0.0d0
|
|
IF ( ispin(i) .EQ. ispin(k) ) THEN
|
|
DO ig = 1, ngw
|
|
temp(ig) = cp(1,ig,k) * cp(1,ig,i) + cp(2,ig,k) * cp(2,ig,i)
|
|
END DO
|
|
csc(k) = 2.0d0 * SUM(temp)
|
|
IF (gstart == 2) csc(k) = csc(k) - temp(1)
|
|
ENDIF
|
|
END DO
|
|
|
|
CALL mp_sum( csc( 1:kmax ), intra_image_comm )
|
|
|
|
!
|
|
! calculate bec(i)=<cp(i)|beta>
|
|
!
|
|
DO inl=1,nhsavb
|
|
DO ig=1,ngw
|
|
temp(ig)=cp(1,ig,i)* DBLE(betae(ig,inl))+ &
|
|
& cp(2,ig,i)*AIMAG(betae(ig,inl))
|
|
END DO
|
|
bec(inl,i)=2.d0*SUM(temp)
|
|
IF (gstart == 2) bec(inl,i)= bec(inl,i)-temp(1)
|
|
END DO
|
|
|
|
CALL mp_sum( bec( 1:nhsavb, i ), intra_image_comm )
|
|
!
|
|
! calculate csc(k)=<cp(i)|S|cp(k)>, k<i
|
|
!
|
|
DO k=1,kmax
|
|
IF (ispin(i).EQ.ispin(k)) THEN
|
|
rsum=0.d0
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
IF(ABS(qq(iv,jv,is)).GT.1.e-5) THEN
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
rsum = rsum + qq(iv,jv,is)*bec(inl,i)*bec(jnl,k)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
csc(k)=csc(k)+rsum
|
|
ENDIF
|
|
END DO
|
|
!
|
|
! orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k<i csc(k)|cp(k)>
|
|
!
|
|
! corresponing bec: bec(i)=<cp(i)|beta>-csc(k)<cp(k)|beta>
|
|
!
|
|
DO k=1,kmax
|
|
DO inl=1,nkbx
|
|
bec(inl,i)=bec(inl,i)-csc(k)*bec(inl,k)
|
|
END DO
|
|
END DO
|
|
|
|
DEALLOCATE( temp )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE gracsc
|
|
|
|
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE smooth_csv( c, v, ngwx, csv, n )
|
|
!-----------------------------------------------------------------------
|
|
|
|
USE gvecw, ONLY: ngw
|
|
USE kinds, ONLY: DP
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: ngwx, n
|
|
REAL(DP) :: c( 2, ngwx )
|
|
REAL(DP) :: v( 2, ngwx, n )
|
|
REAL(DP) :: csv( n )
|
|
INTEGER :: k, ig
|
|
REAL(DP), ALLOCATABLE :: temp(:)
|
|
|
|
!
|
|
! calculate csv(k)=<c|v(k)>
|
|
!
|
|
ALLOCATE( temp( ngw ) )
|
|
|
|
DO k = 1, n
|
|
DO ig = 1, ngw
|
|
temp(ig) = v(1,ig,k) * c(1,ig) + v(2,ig,k) * c(2,ig)
|
|
END DO
|
|
csv(k) = 2.0d0 * SUM(temp)
|
|
IF (gstart == 2) csv(k) = csv(k) - temp(1)
|
|
END DO
|
|
|
|
DEALLOCATE( temp )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE smooth_csv
|
|
|
|
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE grabec( becc, nkbx, betae, c, ngwx )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! on output: bec(i) is recalculated
|
|
!
|
|
USE uspp, ONLY : nkb, nhsavb=>nkbus
|
|
USE gvecw, ONLY: ngw
|
|
USE kinds, ONLY: DP
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: nkbx, ngwx
|
|
COMPLEX(DP) :: betae( ngwx, nkb )
|
|
REAL(DP) :: becc( nkbx ), c( 2, ngwx )
|
|
INTEGER :: ig, inl
|
|
REAL(DP), ALLOCATABLE :: temp(:)
|
|
!
|
|
ALLOCATE( temp( ngw ) )
|
|
!
|
|
! calculate becc=<c|beta>
|
|
!
|
|
DO inl=1,nhsavb
|
|
DO ig=1,ngw
|
|
temp(ig)=c(1,ig)* DBLE(betae(ig,inl))+ &
|
|
& c(2,ig)*AIMAG(betae(ig,inl))
|
|
END DO
|
|
becc(inl)=2.d0*SUM(temp)
|
|
IF (gstart == 2) becc(inl)= becc(inl)-temp(1)
|
|
END DO
|
|
|
|
DEALLOCATE( temp )
|
|
|
|
RETURN
|
|
END SUBROUTINE grabec
|
|
|
|
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE bec_csv( becc, becv, nkbx, csv, n )
|
|
!-----------------------------------------------------------------------
|
|
! requires in input the updated becc and becv(k)
|
|
! on output: csv is updated
|
|
!
|
|
USE ions_base, ONLY: na
|
|
USE cvan, ONLY :nvb, ish
|
|
USE uspp, ONLY : nkb, nhsavb=>nkbus, qq
|
|
USE uspp_param, ONLY: nh
|
|
USE kinds, ONLY: DP
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: nkbx, n
|
|
REAL(DP) :: becc( nkbx )
|
|
REAL(DP) :: becv( nkbx, n )
|
|
REAL(DP) :: csv( n )
|
|
INTEGER :: k, is, iv, jv, ia, inl, jnl
|
|
REAL(DP) :: rsum
|
|
|
|
! calculate csv(k) = csv(k) + <c| SUM_nm |beta(n)><beta(m)|v(k)>, k<i
|
|
!
|
|
DO k=1,n
|
|
rsum=0.d0
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
IF(ABS(qq(iv,jv,is)).GT.1.e-5) THEN
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
rsum = rsum + qq(iv,jv,is)*becc(inl)*becv(jnl,k)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
csv(k)=csv(k)+rsum
|
|
END DO
|
|
!
|
|
RETURN
|
|
END SUBROUTINE bec_csv
|
|
|
|
|
|
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE gram( betae, bec, nkbx, cp, ngwx, n )
|
|
!-----------------------------------------------------------------------
|
|
! gram-schmidt orthogonalization of the set of wavefunctions cp
|
|
!
|
|
USE uspp, ONLY : nkb, nhsavb=> nkbus
|
|
USE gvecw, ONLY : ngw
|
|
USE kinds, ONLY : DP
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: nkbx, ngwx, n
|
|
REAL(DP) :: bec( nkbx, n )
|
|
COMPLEX(DP) :: cp( ngwx, n ), betae( ngwx, nkb )
|
|
!
|
|
REAL(DP) :: anorm, cscnorm
|
|
REAL(DP), ALLOCATABLE :: csc( : )
|
|
INTEGER :: i,k
|
|
EXTERNAL cscnorm
|
|
!
|
|
CALL start_clock( 'gram' )
|
|
|
|
ALLOCATE( csc( n ) )
|
|
!
|
|
DO i = 1, n
|
|
!
|
|
CALL gracsc( bec, nkbx, betae, cp, ngwx, i, csc, n )
|
|
!
|
|
! calculate orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k<i csc(k)|cp(k)>
|
|
!
|
|
DO k = 1, i - 1
|
|
CALL DAXPY( 2*ngw, -csc(k), cp(1,k), 1, cp(1,i), 1 )
|
|
END DO
|
|
anorm = cscnorm( bec, nkbx, cp, ngwx, i, n )
|
|
CALL DSCAL( 2*ngw, 1.0d0/anorm, cp(1,i), 1 )
|
|
!
|
|
! these are the final bec's
|
|
!
|
|
CALL DSCAL( nkbx, 1.0d0/anorm, bec(1,i), 1 )
|
|
END DO
|
|
!
|
|
DEALLOCATE( csc )
|
|
|
|
CALL stop_clock( 'gram' )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE gram
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE initbox ( tau0, taub, irb )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! sets the indexes irb and positions taub for the small boxes
|
|
! around atoms
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE ions_base, ONLY: nsp, na, nat
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3
|
|
USE cell_base, ONLY: ainv, a1, a2, a3
|
|
USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx
|
|
USE control_flags, ONLY: iprsta
|
|
USE io_global, ONLY: stdout
|
|
USE mp_global, ONLY: nproc_image, me_image
|
|
USE fft_base, ONLY: dfftb, dfftp, fft_dlay_descriptor
|
|
USE fft_types, ONLY: fft_box_set
|
|
USE cvan, ONLY: nvb
|
|
|
|
IMPLICIT NONE
|
|
! input
|
|
REAL(DP), INTENT(in) :: tau0(3,nat)
|
|
! output
|
|
INTEGER, INTENT(out) :: irb(3,nat)
|
|
REAL(DP), INTENT(out) :: taub(3,nat)
|
|
! local
|
|
REAL(DP) :: x(3), xmod
|
|
INTEGER :: nr(3), nrb(3), xint, is, ia, i, isa
|
|
!
|
|
nr (1)=nr1
|
|
nr (2)=nr2
|
|
nr (3)=nr3
|
|
nrb(1)=nr1b
|
|
nrb(2)=nr2b
|
|
nrb(3)=nr3b
|
|
!
|
|
isa = 0
|
|
DO is=1,nsp
|
|
DO ia=1,na(is)
|
|
isa = isa + 1
|
|
!
|
|
DO i=1,3
|
|
!
|
|
! bring atomic positions to crystal axis
|
|
!
|
|
x(i) = ainv(i,1)*tau0(1,isa) + &
|
|
& ainv(i,2)*tau0(2,isa) + &
|
|
& ainv(i,3)*tau0(3,isa)
|
|
!
|
|
! bring x in the range between 0 and 1
|
|
!
|
|
x(i) = MOD(x(i),1.d0)
|
|
IF (x(i).LT.0.d0) x(i)=x(i)+1.d0
|
|
!
|
|
! case of nrb(i) even
|
|
!
|
|
IF (MOD(nrb(i),2).EQ.0) THEN
|
|
!
|
|
! find irb = index of the grid point at the corner of the small box
|
|
! (the indices of the small box run from irb to irb+nrb-1)
|
|
!
|
|
xint=INT(x(i)*nr(i))
|
|
irb (i,isa)=xint+1-nrb(i)/2+1
|
|
IF(irb(i,isa).LT.1) irb(i,isa)=irb(i,isa)+nr(i)
|
|
!
|
|
! x(i) are the atomic positions in crystal coordinates, where the
|
|
! "crystal lattice" is the small box lattice and the origin is at
|
|
! the corner of the small box. Used to calculate phases exp(iG*taub)
|
|
!
|
|
xmod=x(i)*nr(i)-xint
|
|
x(i)=(xmod+nrb(i)/2-1)/nr(i)
|
|
ELSE
|
|
!
|
|
! case of nrb(i) odd - see above for comments
|
|
!
|
|
xint=NINT(x(i)*nr(i))
|
|
irb (i,isa)=xint+1-(nrb(i)-1)/2
|
|
IF(irb(i,isa).LT.1) irb(i,isa)=irb(i,isa)+nr(i)
|
|
xmod=x(i)*nr(i)-xint
|
|
x(i)=(xmod+(nrb(i)-1)/2)/nr(i)
|
|
END IF
|
|
END DO
|
|
!
|
|
! bring back taub in cartesian coordinates
|
|
!
|
|
DO i=1,3
|
|
taub(i,isa)= x(1)*a1(i) + x(2)*a2(i) + x(3)*a3(i)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
|
|
CALL fft_box_set( dfftb, nr1b, nr2b, nr3b, nr1bx, nr2bx, nr3bx, &
|
|
nat, irb, me_image+1, nproc_image, dfftp%npp, dfftp%ipp )
|
|
|
|
IF( iprsta > 2 ) THEN
|
|
isa = 1
|
|
DO is=1,nsp
|
|
WRITE( stdout,'(/,2x,''species= '',i2)') is
|
|
DO ia=1,na(is)
|
|
WRITE( stdout,2000) ia, (irb(i,isa),i=1,3)
|
|
2000 FORMAT(2x,'atom= ',i3,' irb1= ',i3,' irb2= ',i3,' irb3= ',i3)
|
|
isa = isa + 1
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
|
|
#ifdef __PARA
|
|
!
|
|
! for processor that do not call fft on the box
|
|
! artificially start the clock
|
|
!
|
|
CALL start_clock( 'fftb' )
|
|
CALL stop_clock( 'fftb' )
|
|
!
|
|
#endif
|
|
!
|
|
RETURN
|
|
END SUBROUTINE initbox
|
|
!
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE newd(vr,irb,eigrb,rhovan,fion)
|
|
!-----------------------------------------------------------------------
|
|
! this routine calculates array deeq:
|
|
! deeq_i,lm = \int V_eff(r) q_i,lm(r) dr
|
|
! and the corresponding term in forces
|
|
! fion_i = \int V_eff(r) \sum_lm rho_lm (dq_i,lm(r)/dR_i) dr
|
|
! where
|
|
! rho_lm = \sum_j f_j <psi_j|beta_l><beta_m|psi_j>
|
|
!
|
|
USE kinds, ONLY: dp
|
|
USE uspp_param, ONLY: nh, nhm
|
|
USE uspp, ONLY: deeq
|
|
USE cvan, ONLY: nvb
|
|
USE ions_base, ONLY: nat, nsp, na
|
|
USE parameters, ONLY: nsx
|
|
USE constants, ONLY: pi, fpi
|
|
USE grid_dimensions, ONLY: nr3, nnr => nnrx
|
|
USE gvecb, ONLY: ngb, npb, nmb, gxb
|
|
USE small_box, ONLY: omegab, tpibab
|
|
USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, &
|
|
nr1bx, nr2bx, nr3bx, nnrb => nnrbx
|
|
USE qgb_mod, ONLY: qgb
|
|
USE electrons_base, ONLY: nspin
|
|
USE control_flags, ONLY: iprint, thdyn, tfor, tprnfor
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE cp_interfaces, ONLY: invfft
|
|
USE fft_base, ONLY: dfftb
|
|
!
|
|
IMPLICIT NONE
|
|
! input
|
|
INTEGER irb(3,nat)
|
|
REAL(DP) rhovan(nhm*(nhm+1)/2,nat,nspin)
|
|
COMPLEX(DP) eigrb(ngb,nat)
|
|
REAL(DP) vr(nnr,nspin)
|
|
! output
|
|
REAL(DP) fion(3,nat)
|
|
! local
|
|
INTEGER isup,isdw,iss, iv,ijv,jv, ik, nfft, isa, ia, is, ig
|
|
REAL(DP) fvan(3,nat,nsx), fac, fac1, fac2, boxdotgrid
|
|
COMPLEX(DP) ci, facg1, facg2
|
|
COMPLEX(DP), ALLOCATABLE :: qv(:)
|
|
EXTERNAL boxdotgrid
|
|
!
|
|
CALL start_clock( 'newd' )
|
|
ci=(0.d0,1.d0)
|
|
fac=omegab/DBLE(nr1b*nr2b*nr3b)
|
|
deeq (:,:,:,:) = 0.d0
|
|
fvan (:,:,:) = 0.d0
|
|
|
|
ALLOCATE( qv( nnrb ) )
|
|
!
|
|
! calculation of deeq_i,lm = \int V_eff(r) q_i,lm(r) dr
|
|
!
|
|
isa=1
|
|
DO is=1,nvb
|
|
#ifdef __PARA
|
|
DO ia=1,na(is)
|
|
nfft=1
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 15
|
|
#else
|
|
DO ia=1,na(is),2
|
|
nfft=2
|
|
#endif
|
|
IF( ia .EQ. na(is) ) nfft=1
|
|
!
|
|
! two ffts at the same time, on two atoms (if possible: nfft=2)
|
|
!
|
|
DO iv=1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
qv(:) = (0.d0, 0.d0)
|
|
IF (nfft.EQ.2) THEN
|
|
DO ig=1,ngb
|
|
qv(npb(ig))= eigrb(ig,isa )*qgb(ig,ijv,is) &
|
|
& + ci*eigrb(ig,isa+1)*qgb(ig,ijv,is)
|
|
qv(nmb(ig))= CONJG( &
|
|
& eigrb(ig,isa )*qgb(ig,ijv,is)) &
|
|
& + ci*CONJG( &
|
|
& eigrb(ig,isa+1)*qgb(ig,ijv,is))
|
|
END DO
|
|
ELSE
|
|
DO ig=1,ngb
|
|
qv(npb(ig)) = eigrb(ig,isa)*qgb(ig,ijv,is)
|
|
qv(nmb(ig)) = CONJG( &
|
|
& eigrb(ig,isa)*qgb(ig,ijv,is))
|
|
END DO
|
|
END IF
|
|
!
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
!
|
|
DO iss=1,nspin
|
|
deeq(iv,jv,isa,iss) = fac * &
|
|
& boxdotgrid(irb(1,isa),1,qv,vr(1,iss))
|
|
IF (iv.NE.jv) &
|
|
& deeq(jv,iv,isa,iss)=deeq(iv,jv,isa,iss)
|
|
!
|
|
IF (nfft.EQ.2) THEN
|
|
deeq(iv,jv,isa+1,iss) = fac* &
|
|
& boxdotgrid(irb(1,isa+1),2,qv,vr(1,iss))
|
|
IF (iv.NE.jv) &
|
|
& deeq(jv,iv,isa+1,iss)=deeq(iv,jv,isa+1,iss)
|
|
END IF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
15 isa=isa+nfft
|
|
END DO
|
|
END DO
|
|
|
|
CALL mp_sum( deeq, intra_image_comm )
|
|
|
|
IF (.NOT.( tfor .OR. thdyn .OR. tprnfor ) ) go to 10
|
|
!
|
|
! calculation of fion_i = \int V_eff(r) \sum_lm rho_lm (dq_i,lm(r)/dR_i) dr
|
|
!
|
|
isa=1
|
|
IF(nspin.EQ.1) THEN
|
|
! =================================================================
|
|
! case nspin=1: two ffts at the same time, on two atoms (if possible)
|
|
! -----------------------------------------------------------------
|
|
iss=1
|
|
isa=1
|
|
DO is=1,nvb
|
|
#ifdef __PARA
|
|
DO ia=1,na(is)
|
|
nfft=1
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 20
|
|
#else
|
|
DO ia=1,na(is),2
|
|
nfft=2
|
|
#endif
|
|
IF( ia.EQ.na(is)) nfft=1
|
|
DO ik=1,3
|
|
qv(:) = (0.d0, 0.d0)
|
|
DO iv=1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
IF(iv.NE.jv) THEN
|
|
fac1=2.d0*fac*tpibab*rhovan(ijv,isa,iss)
|
|
IF (nfft.EQ.2) fac2=2.d0*fac*tpibab* &
|
|
& rhovan(ijv,isa+1,iss)
|
|
ELSE
|
|
fac1= fac*tpibab*rhovan(ijv,isa,iss)
|
|
IF (nfft.EQ.2) fac2= fac*tpibab* &
|
|
& rhovan(ijv,isa+1,iss)
|
|
ENDIF
|
|
IF (nfft.EQ.2) THEN
|
|
DO ig=1,ngb
|
|
facg1 = CMPLX(0.d0,-gxb(ik,ig)) * &
|
|
& qgb(ig,ijv,is) * fac1
|
|
facg2 = CMPLX(0.d0,-gxb(ik,ig)) * &
|
|
& qgb(ig,ijv,is) * fac2
|
|
qv(npb(ig)) = qv(npb(ig)) &
|
|
& + eigrb(ig,isa )*facg1 &
|
|
& + ci*eigrb(ig,isa+1)*facg2
|
|
qv(nmb(ig)) = qv(nmb(ig)) &
|
|
& + CONJG(eigrb(ig,isa )*facg1)&
|
|
& +ci*CONJG(eigrb(ig,isa+1)*facg2)
|
|
END DO
|
|
ELSE
|
|
DO ig=1,ngb
|
|
facg1 = CMPLX(0.d0,-gxb(ik,ig)) * &
|
|
& qgb(ig,ijv,is)*fac1
|
|
qv(npb(ig)) = qv(npb(ig)) &
|
|
& + eigrb(ig,isa)*facg1
|
|
qv(nmb(ig)) = qv(nmb(ig)) &
|
|
& + CONJG( eigrb(ig,isa)*facg1)
|
|
END DO
|
|
END IF
|
|
END DO
|
|
END DO
|
|
!
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
!
|
|
fvan(ik,ia,is) = &
|
|
& boxdotgrid(irb(1,isa),1,qv,vr(1,iss))
|
|
!
|
|
IF (nfft.EQ.2) fvan(ik,ia+1,is) = &
|
|
& boxdotgrid(irb(1,isa+1),2,qv,vr(1,iss))
|
|
END DO
|
|
20 isa = isa+nfft
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
! =================================================================
|
|
! case nspin=2: up and down spin fft's combined into a single fft
|
|
! -----------------------------------------------------------------
|
|
isup=1
|
|
isdw=2
|
|
isa=1
|
|
DO is=1,nvb
|
|
DO ia=1,na(is)
|
|
#ifdef __PARA
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 25
|
|
#endif
|
|
DO ik=1,3
|
|
qv(:) = (0.d0, 0.d0)
|
|
!
|
|
DO iv=1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
IF(iv.NE.jv) THEN
|
|
fac1=2.d0*fac*tpibab*rhovan(ijv,isa,isup)
|
|
fac2=2.d0*fac*tpibab*rhovan(ijv,isa,isdw)
|
|
ELSE
|
|
fac1= fac*tpibab*rhovan(ijv,isa,isup)
|
|
fac2= fac*tpibab*rhovan(ijv,isa,isdw)
|
|
END IF
|
|
DO ig=1,ngb
|
|
facg1 = fac1 * CMPLX(0.d0,-gxb(ik,ig)) * &
|
|
& qgb(ig,ijv,is) * eigrb(ig,isa)
|
|
facg2 = fac2 * CMPLX(0.d0,-gxb(ik,ig)) * &
|
|
& qgb(ig,ijv,is) * eigrb(ig,isa)
|
|
qv(npb(ig)) = qv(npb(ig)) &
|
|
& + facg1 + ci*facg2
|
|
qv(nmb(ig)) = qv(nmb(ig)) &
|
|
& +CONJG(facg1)+ci*CONJG(facg2)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
!
|
|
fvan(ik,ia,is) = &
|
|
& boxdotgrid(irb(1,isa),isup,qv,vr(1,isup)) + &
|
|
& boxdotgrid(irb(1,isa),isdw,qv,vr(1,isdw))
|
|
END DO
|
|
25 isa = isa+1
|
|
END DO
|
|
END DO
|
|
END IF
|
|
|
|
CALL mp_sum( fvan, intra_image_comm )
|
|
|
|
isa = 0
|
|
DO is = 1, nvb
|
|
DO ia = 1, na(is)
|
|
isa = isa + 1
|
|
fion(:,isa) = fion(:,isa) - fvan(:,ia,is)
|
|
END DO
|
|
END DO
|
|
|
|
DEALLOCATE( qv )
|
|
!
|
|
10 CALL stop_clock( 'newd' )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE newd
|
|
|
|
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE nlfl(bec,becdr,lambda,fion)
|
|
!-----------------------------------------------------------------------
|
|
! contribution to fion due to the orthonormality constraint
|
|
!
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE io_global, ONLY: stdout
|
|
USE ions_base, ONLY: na, nsp, nat
|
|
USE uspp, ONLY: nhsa=>nkb, qq
|
|
USE uspp_param, ONLY: nhm, nh
|
|
USE cvan, ONLY: ish, nvb
|
|
USE electrons_base, ONLY: nbspx, nbsp, nudx, nspin, iupdwn, nupdwn
|
|
USE constants, ONLY: pi, fpi
|
|
!
|
|
IMPLICIT NONE
|
|
REAL(DP) bec(nhsa,nbsp), becdr(nhsa,nbsp,3), lambda(nudx,nudx,nspin)
|
|
REAL(DP) fion(3,nat)
|
|
!
|
|
INTEGER k, is, ia, iv, jv, i, j, inl, isa, iss, nss, istart
|
|
REAL(DP), ALLOCATABLE :: temp(:,:), tmpbec(:,:),tmpdr(:,:)
|
|
|
|
#if defined __TRUE_BGL
|
|
COMPLEX*16 :: B, A1, A2, A3, C1, C2, C3
|
|
INTEGER :: FLP, N
|
|
#endif
|
|
|
|
!
|
|
CALL start_clock( 'nlfl' )
|
|
!
|
|
#if defined __TRUE_BGL
|
|
ALLOCATE( temp( nudx, nudx ), tmpbec( nhm, nudx ), tmpdr( nudx, nhm ) )
|
|
|
|
|
|
do k=1, 3
|
|
|
|
isa = 0
|
|
|
|
do is=1,nvb
|
|
|
|
do ia=1,na(is)
|
|
|
|
isa = isa + 1
|
|
!
|
|
DO iss = 1, nspin
|
|
!
|
|
nss = nupdwn( iss )
|
|
istart = iupdwn( iss )
|
|
|
|
tmpbec = 0.d0
|
|
tmpdr = 0.d0
|
|
!
|
|
do iv=1,nh(is)
|
|
do jv=1,nh(is)
|
|
inl=ish(is)+(jv-1)*na(is)+ia
|
|
if(abs(qq(iv,jv,is)).gt.1.e-5) then
|
|
do i=1,nss
|
|
tmpbec(iv,i)=tmpbec(iv,i) &
|
|
& + qq(iv,jv,is)*bec(inl,i+istart-1)
|
|
end do
|
|
endif
|
|
end do
|
|
end do
|
|
|
|
DO iv=1,nh(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
DO i=1,nss
|
|
tmpdr(i,iv)=becdr(inl,i+istart-1,k)
|
|
END DO
|
|
END DO
|
|
|
|
|
|
if ( nh(is) .gt. 0 )then
|
|
!
|
|
|
|
CALL DGEMM &
|
|
( 'N', 'N', nss, nss, nh(is), 1.0d0, tmpdr, nudx, tmpbec, nhm, 0.0d0, temp, nudx )
|
|
!
|
|
! temp = 0d0
|
|
! call MXMA &
|
|
! & (tmpdr,1,nudx,tmpbec,1,nhm,temp,1,nudx,nss,nh(is),nss)
|
|
!
|
|
!---------------------------------------------------------
|
|
!BG/L 440d specific implementation:
|
|
!At each inner i-loop 1 pair of two consequtive elements
|
|
!of the j-th column of matrix temp are performed.
|
|
!Then, a parallel fused multiply add operation is issued
|
|
!Any remaining data is handled after the loop
|
|
!---------------------------------------------------------
|
|
B = (0D0,0D0)
|
|
A1 = (0D0,0D0)
|
|
C1 = (0D0,0D0)
|
|
|
|
do j=1,nss
|
|
do i=1,nss,2
|
|
A1 = LOADFP(temp(i,j))
|
|
B = LOADFP(lambda(i,j,iss))
|
|
B = FPMUL(B,(2D0,2D0))
|
|
C1 = FPMADD(C1,A1,B)
|
|
end do
|
|
!-------------------------
|
|
!Handle any remaining data
|
|
!-------------------------
|
|
IF (MOD(nss,2).NE.0) THEN
|
|
fion(k,isa) = fion(k,isa) + 2D0*temp(nss,j)*lambda(nss,j,iss)
|
|
ENDIF
|
|
end do
|
|
fion(k,isa) = fion(k,isa) + DBLE(C1)+AIMAG(C1)
|
|
endif
|
|
|
|
end do
|
|
!
|
|
end do
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
#else
|
|
|
|
|
|
ALLOCATE( temp( nudx, nudx ), tmpbec( nhm, nudx ), tmpdr( nudx, nhm ) )
|
|
|
|
DO k=1,3
|
|
isa = 0
|
|
DO is=1,nvb
|
|
DO ia=1,na(is)
|
|
isa = isa + 1
|
|
!
|
|
DO iss = 1, nspin
|
|
!
|
|
nss = nupdwn( iss )
|
|
istart = iupdwn( iss )
|
|
!
|
|
tmpbec = 0.d0
|
|
tmpdr = 0.d0
|
|
!
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
inl=ish(is)+(jv-1)*na(is)+ia
|
|
IF(ABS(qq(iv,jv,is)).GT.1.e-5) THEN
|
|
DO i=1,nss
|
|
tmpbec(iv,i)=tmpbec(iv,i) &
|
|
& + qq(iv,jv,is)*bec(inl,i+istart-1)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
!
|
|
DO iv=1,nh(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
DO i=1,nss
|
|
tmpdr(i,iv)=becdr(inl,i+istart-1,k)
|
|
END DO
|
|
END DO
|
|
!
|
|
IF(nh(is).GT.0)THEN
|
|
!
|
|
! temp = 0.d0
|
|
! CALL MXMA &
|
|
! & (tmpdr,1,nudx,tmpbec,1,nhm,temp,1,nudx,nss,nh(is),nss)
|
|
!
|
|
CALL DGEMM &
|
|
( 'N', 'N', nss, nss, nh(is), 1.0d0, tmpdr, nudx, tmpbec, nhm, 0.0d0, temp, nudx )
|
|
!
|
|
DO j=1,nss
|
|
DO i=1,nss
|
|
fion(k,isa) = fion(k,isa) + 2D0*temp(i,j)*lambda(i,j,iss)
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
|
|
END DO
|
|
!
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
|
|
#endif
|
|
|
|
|
|
DEALLOCATE( temp, tmpbec, tmpdr )
|
|
!
|
|
CALL stop_clock( 'nlfl' )
|
|
!
|
|
RETURN
|
|
|
|
END SUBROUTINE nlfl
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE pbc(rin,a1,a2,a3,ainv,rout)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! brings atoms inside the unit cell
|
|
!
|
|
USE kinds, ONLY: DP
|
|
|
|
IMPLICIT NONE
|
|
! input
|
|
REAL(DP) rin(3), a1(3),a2(3),a3(3), ainv(3,3)
|
|
! output
|
|
REAL(DP) rout(3)
|
|
! local
|
|
REAL(DP) x,y,z
|
|
!
|
|
! bring atomic positions to crystal axis
|
|
!
|
|
x = ainv(1,1)*rin(1)+ainv(1,2)*rin(2)+ainv(1,3)*rin(3)
|
|
y = ainv(2,1)*rin(1)+ainv(2,2)*rin(2)+ainv(2,3)*rin(3)
|
|
z = ainv(3,1)*rin(1)+ainv(3,2)*rin(2)+ainv(3,3)*rin(3)
|
|
!
|
|
! bring x,y,z in the range between -0.5 and 0.5
|
|
!
|
|
x = x - NINT(x)
|
|
y = y - NINT(y)
|
|
z = z - NINT(z)
|
|
!
|
|
! bring atomic positions back in cartesian axis
|
|
!
|
|
rout(1) = x*a1(1)+y*a2(1)+z*a3(1)
|
|
rout(2) = x*a1(2)+y*a2(2)+z*a3(2)
|
|
rout(3) = x*a1(3)+y*a2(3)+z*a3(3)
|
|
!
|
|
RETURN
|
|
END SUBROUTINE pbc
|
|
|
|
!
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE prefor(eigr,betae)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! input : eigr = e^-ig.r_i
|
|
! output: betae_i,i(g) = (-i)**l beta_i,i(g) e^-ig.r_i
|
|
!
|
|
USE kinds, ONLY : DP
|
|
USE ions_base, ONLY : nsp, na, nat
|
|
USE gvecw, ONLY : ngw
|
|
USE cvan, ONLY : ish
|
|
USE uspp, ONLY : nkb, beta, nhtol
|
|
USE uspp_param, ONLY : nh
|
|
!
|
|
IMPLICIT NONE
|
|
COMPLEX(DP) :: eigr( ngw, nat )
|
|
COMPLEX(DP) :: betae( ngw, nkb )
|
|
!
|
|
INTEGER :: is, iv, ia, inl, ig, isa
|
|
COMPLEX(DP) :: ci
|
|
!
|
|
CALL start_clock( 'prefor' )
|
|
isa = 0
|
|
DO is=1,nsp
|
|
DO iv=1,nh(is)
|
|
ci=(0.0d0,-1.0d0)**nhtol(iv,is)
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
DO ig=1,ngw
|
|
betae(ig,inl)=ci*beta(ig,iv,is)*eigr(ig,ia+isa)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
isa = isa + na(is)
|
|
END DO
|
|
CALL stop_clock( 'prefor' )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE prefor
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE projwfc( c, nx, eigr, betae, n, ei )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Projection on atomic wavefunctions
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE constants, ONLY: autoev
|
|
USE io_global, ONLY: stdout
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE mp, ONLY: mp_sum
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE ions_base, ONLY: nsp, na, nat
|
|
USE uspp, ONLY: nhsa => nkb
|
|
USE atom, ONLY: nchi, lchi
|
|
!
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(IN) :: nx, n
|
|
COMPLEX(DP), INTENT(IN) :: c( ngw, nx ), eigr(ngw,nat), betae(ngw,nhsa)
|
|
REAL(DP), INTENT(IN) :: ei( nx )
|
|
!
|
|
COMPLEX(DP), ALLOCATABLE :: wfc(:,:), swfc(:,:), becwfc(:,:)
|
|
REAL(DP), ALLOCATABLE :: overlap(:,:), e(:), z(:,:)
|
|
REAL(DP), ALLOCATABLE :: proj(:,:), temp(:)
|
|
REAL(DP) :: somma
|
|
|
|
INTEGER :: n_atomic_wfc
|
|
INTEGER :: is, ia, nb, l, m, k, i
|
|
!
|
|
! calculate number of atomic states
|
|
!
|
|
n_atomic_wfc = 0
|
|
!
|
|
DO is=1,nsp
|
|
DO nb = 1,nchi(is)
|
|
l = lchi(nb,is)
|
|
n_atomic_wfc = n_atomic_wfc + (2*l+1)*na(is)
|
|
END DO
|
|
END DO
|
|
IF ( n_atomic_wfc .EQ. 0 ) RETURN
|
|
!
|
|
ALLOCATE( wfc( ngw, n_atomic_wfc ) )
|
|
!
|
|
! calculate wfc = atomic states
|
|
!
|
|
CALL atomic_wfc( eigr, n_atomic_wfc, wfc )
|
|
!
|
|
! calculate bec = <beta|wfc>
|
|
!
|
|
ALLOCATE( becwfc( nhsa, n_atomic_wfc ) )
|
|
!
|
|
CALL nlsm1( n_atomic_wfc, 1, nsp, eigr, wfc, becwfc )
|
|
!
|
|
! calculate swfc = S|wfc>
|
|
!
|
|
ALLOCATE( swfc( ngw, n_atomic_wfc ) )
|
|
!
|
|
CALL s_wfc( n_atomic_wfc, becwfc, betae, wfc, swfc )
|
|
!
|
|
! calculate overlap(i,j) = <wfc_i|S|wfc_j>
|
|
!
|
|
ALLOCATE( overlap( n_atomic_wfc, n_atomic_wfc ) )
|
|
|
|
CALL DGEMM &
|
|
( 'T', 'N', n_atomic_wfc, n_atomic_wfc, 2*ngw, 1.0d0, wfc, 2*ngw, &
|
|
swfc, 2*ngw, 0.0d0, overlap, n_atomic_wfc )
|
|
|
|
! CALL MXMA( wfc, 2*ngw, 1, swfc, 1, 2*ngw, overlap, 1, &
|
|
! & n_atomic_wfc, n_atomic_wfc, 2*ngw, n_atomic_wfc )
|
|
|
|
CALL mp_sum( overlap, intra_image_comm )
|
|
|
|
overlap = overlap * 2.d0
|
|
IF (gstart == 2) THEN
|
|
DO l=1,n_atomic_wfc
|
|
DO m=1,n_atomic_wfc
|
|
overlap(m,l)=overlap(m,l)-DBLE(wfc(1,m))*DBLE(swfc(1,l))
|
|
END DO
|
|
END DO
|
|
END IF
|
|
!
|
|
! calculate (overlap)^(-1/2)(i,j). An orthonormal set of vectors |wfc_i>
|
|
! is obtained by introducing |wfc_j>=(overlap)^(-1/2)(i,j)*S|wfc_i>
|
|
!
|
|
ALLOCATE(z(n_atomic_wfc,n_atomic_wfc))
|
|
ALLOCATE(e(n_atomic_wfc))
|
|
!
|
|
CALL rdiag( n_atomic_wfc, overlap, n_atomic_wfc, e, z )
|
|
!
|
|
overlap=0.d0
|
|
!
|
|
DO l=1,n_atomic_wfc
|
|
DO m=1,n_atomic_wfc
|
|
DO k=1,n_atomic_wfc
|
|
overlap(l,m)=overlap(l,m)+z(m,k)*z(l,k)/SQRT(e(k))
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
DEALLOCATE(e)
|
|
DEALLOCATE(z)
|
|
!
|
|
! calculate |wfc_j>=(overlap)^(-1/2)(i,j)*S|wfc_i> (note the S matrix!)
|
|
!
|
|
wfc=0.d0
|
|
DO m=1,n_atomic_wfc
|
|
DO l=1,n_atomic_wfc
|
|
wfc(:,m)=wfc(:,m)+overlap(l,m)*swfc(:,l)
|
|
END DO
|
|
END DO
|
|
DEALLOCATE(overlap)
|
|
DEALLOCATE(swfc)
|
|
DEALLOCATE(becwfc)
|
|
!
|
|
! calculate proj = <c|S|wfc>
|
|
!
|
|
ALLOCATE(proj(n,n_atomic_wfc))
|
|
|
|
ALLOCATE(temp(ngw))
|
|
|
|
DO m=1,n
|
|
DO l=1,n_atomic_wfc
|
|
temp(:)=DBLE(CONJG(c(:,m))*wfc(:,l))
|
|
proj(m,l)=2.d0*SUM(temp)
|
|
IF (gstart == 2) proj(m,l)=proj(m,l)-temp(1)
|
|
END DO
|
|
END DO
|
|
|
|
DEALLOCATE(temp)
|
|
|
|
CALL mp_sum( proj, intra_image_comm )
|
|
|
|
i=0
|
|
WRITE( stdout, 90 )
|
|
WRITE( stdout, 100 )
|
|
DO is=1,nsp
|
|
DO nb = 1,nchi(is)
|
|
l=lchi(nb,is)
|
|
DO m = -l,l
|
|
DO ia=1,na(is)
|
|
i=i+1
|
|
END DO
|
|
WRITE( stdout, 110 ) i-na(is)+1, i, na(is), is, nb, l, m
|
|
END DO
|
|
END DO
|
|
END DO
|
|
|
|
WRITE( stdout,*)
|
|
DO m=1,n
|
|
somma=0.d0
|
|
DO l=1,n_atomic_wfc
|
|
somma=somma+proj(m,l)**2
|
|
END DO
|
|
WRITE( stdout, 120 ) m, somma, ei(m)*autoev
|
|
WRITE( stdout, 130 ) (ABS(proj(m,l)),l=1,n_atomic_wfc)
|
|
END DO
|
|
|
|
90 FORMAT( 3X,'Projection on atomic states')
|
|
100 FORMAT( 3X,'atomic state atom specie wfc l m')
|
|
110 FORMAT( 3X, I4, ' - ', I4, 4X, I4, 6X, I3, I5, I4,I3)
|
|
120 FORMAT( 3X,'state # ',i4,' sum c^2 = ',f7.4, ' eV = ', F7.2 )
|
|
130 FORMAT( 3X, 10f7.4)
|
|
|
|
!
|
|
DEALLOCATE(proj)
|
|
DEALLOCATE(wfc)
|
|
RETURN
|
|
END SUBROUTINE projwfc
|
|
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE rdiag ( n, h, ldh, e, v )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! calculates all the eigenvalues and eigenvectors of a complex
|
|
! hermitean matrix H . On output, the matrix H is destroyed
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE parallel_toolkit, ONLY: dspev_drv
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(in) :: n, ldh
|
|
REAL(DP), INTENT(inout):: h(ldh,n)
|
|
REAL(DP), INTENT(out) :: e(n)
|
|
REAL(DP), INTENT(out) :: v(ldh,n)
|
|
!
|
|
INTEGER :: i, j, k
|
|
REAL(DP), ALLOCATABLE :: ap( : )
|
|
!
|
|
ALLOCATE( ap( n * ( n + 1 ) / 2 ) )
|
|
|
|
K = 0
|
|
DO J = 1, n
|
|
DO I = J, n
|
|
K = K + 1
|
|
ap( k ) = h( i, j )
|
|
END DO
|
|
END DO
|
|
|
|
CALL dspev_drv( 'V', 'L', n, ap, e, v, ldh )
|
|
|
|
DEALLOCATE( ap )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE rdiag
|
|
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE rhov(irb,eigrb,rhovan,rhog,rhor)
|
|
!-----------------------------------------------------------------------
|
|
! Add Vanderbilt contribution to rho(r) and rho(g)
|
|
!
|
|
! n_v(g) = sum_i,ij rho_i,ij q_i,ji(g) e^-ig.r_i
|
|
!
|
|
! routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g)
|
|
!
|
|
USE kinds, ONLY: dp
|
|
USE ions_base, ONLY: nat, na, nsp
|
|
USE io_global, ONLY: stdout
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE mp, ONLY: mp_sum
|
|
USE cvan, ONLY: nvb
|
|
USE uspp_param, ONLY: nh, nhm
|
|
USE uspp, ONLY: deeq
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3, &
|
|
nr1x, nr2x, nr3x, nnr => nnrx
|
|
USE electrons_base, ONLY: nspin
|
|
USE gvecb
|
|
USE gvecp, ONLY: ng => ngm
|
|
USE cell_base, ONLY: omega, ainv
|
|
USE small_box, ONLY: omegab
|
|
USE smallbox_grid_dimensions, ONLY: nr1b, nr2b, nr3b, &
|
|
nr1bx, nr2bx, nr3bx, nnrb => nnrbx
|
|
USE control_flags, ONLY: iprint, iprsta, tpre
|
|
USE qgb_mod
|
|
USE recvecs_indexes, ONLY: np, nm
|
|
USE cp_interfaces, ONLY: fwfft, invfft
|
|
USE fft_base, ONLY: dfftb
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(8) :: rhovan(nhm*(nhm+1)/2,nat,nspin)
|
|
INTEGER, INTENT(in) :: irb(3,nat)
|
|
COMPLEX(8), INTENT(in):: eigrb(ngb,nat)
|
|
REAL(8), INTENT(inout):: rhor(nnr,nspin)
|
|
COMPLEX(8), INTENT(inout):: rhog(ng,nspin)
|
|
!
|
|
INTEGER isup, isdw, nfft, ifft, iv, jv, ig, ijv, is, iss, &
|
|
& isa, ia, ir, i, j
|
|
REAL(8) sumrho
|
|
COMPLEX(8) ci, fp, fm, ca
|
|
COMPLEX(8), ALLOCATABLE:: qgbt(:,:)
|
|
COMPLEX(8), ALLOCATABLE:: v(:)
|
|
COMPLEX(8), ALLOCATABLE:: qv(:)
|
|
!
|
|
IF (nvb.EQ.0) RETURN
|
|
CALL start_clock( 'rhov' )
|
|
ci=(0.d0,1.d0)
|
|
!
|
|
!
|
|
ALLOCATE( v( nnr ) )
|
|
ALLOCATE( qv( nnrb ) )
|
|
v (:) = (0.d0, 0.d0)
|
|
ALLOCATE( qgbt( ngb, 2 ) )
|
|
|
|
!
|
|
IF(nspin.EQ.1) THEN
|
|
!
|
|
! nspin=1 : two fft at a time, one per atom, if possible
|
|
!
|
|
iss=1
|
|
isa=1
|
|
|
|
DO is = 1, nvb
|
|
|
|
#ifdef __PARA
|
|
|
|
DO ia = 1, na(is)
|
|
nfft = 1
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 15
|
|
#else
|
|
|
|
DO ia = 1, na(is), 2
|
|
nfft = 2
|
|
#endif
|
|
|
|
IF( ia .EQ. na(is) ) nfft = 1
|
|
|
|
!
|
|
! nfft=2 if two ffts at the same time are performed
|
|
!
|
|
DO ifft=1,nfft
|
|
qgbt(:,ifft) = (0.d0, 0.d0)
|
|
DO iv= 1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
sumrho=rhovan(ijv,isa+ifft-1,iss)
|
|
IF(iv.NE.jv) sumrho=2.d0*sumrho
|
|
DO ig=1,ngb
|
|
qgbt(ig,ifft)=qgbt(ig,ifft) + sumrho*qgb(ig,ijv,is)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! add structure factor
|
|
!
|
|
qv(:) = (0.d0, 0.d0)
|
|
IF(nfft.EQ.2)THEN
|
|
DO ig=1,ngb
|
|
qv(npb(ig))= &
|
|
eigrb(ig,isa )*qgbt(ig,1) &
|
|
+ ci* eigrb(ig,isa+1)*qgbt(ig,2)
|
|
qv(nmb(ig))= &
|
|
CONJG(eigrb(ig,isa )*qgbt(ig,1)) &
|
|
+ ci*CONJG(eigrb(ig,isa+1)*qgbt(ig,2))
|
|
END DO
|
|
ELSE
|
|
DO ig=1,ngb
|
|
qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1)
|
|
qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1))
|
|
END DO
|
|
ENDIF
|
|
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
|
|
!
|
|
! qv = US augmentation charge in real space on box grid
|
|
! for atomic species is, real(qv)=atom ia, imag(qv)=atom ia+1
|
|
|
|
IF(iprsta.GT.2) THEN
|
|
ca = SUM(qv)
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom g-sp = ', &
|
|
& omegab*DBLE(qgbt(1,1))
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom r-sp = ', &
|
|
& omegab*DBLE(ca)/(nr1b*nr2b*nr3b)
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom g-sp = ', &
|
|
& omegab*DBLE(qgbt(1,2))
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom r-sp = ', &
|
|
& omegab*AIMAG(ca)/(nr1b*nr2b*nr3b)
|
|
ENDIF
|
|
!
|
|
! add qv(r) to v(r), in real space on the dense grid
|
|
!
|
|
CALL box2grid(irb(1,isa),1,qv,v)
|
|
IF (nfft.EQ.2) CALL box2grid(irb(1,isa+1),2,qv,v)
|
|
15 isa=isa+nfft
|
|
!
|
|
END DO
|
|
END DO
|
|
!
|
|
! rhor(r) = total (smooth + US) charge density in real space
|
|
!
|
|
DO ir=1,nnr
|
|
rhor(ir,iss)=rhor(ir,iss)+DBLE(v(ir))
|
|
END DO
|
|
!
|
|
IF(iprsta.GT.2) THEN
|
|
ca = SUM(v)
|
|
|
|
CALL mp_sum( ca, intra_image_comm )
|
|
|
|
WRITE( stdout,'(a,2f12.8)') &
|
|
& ' rhov: int n_v(r) dr = ',omega*ca/(nr1*nr2*nr3)
|
|
ENDIF
|
|
!
|
|
CALL fwfft('Dense',v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
|
|
!
|
|
IF(iprsta.GT.2) THEN
|
|
WRITE( stdout,*) ' rhov: smooth ',omega*rhog(1,iss)
|
|
WRITE( stdout,*) ' rhov: vander ',omega*v(1)
|
|
WRITE( stdout,*) ' rhov: all ',omega*(rhog(1,iss)+v(1))
|
|
ENDIF
|
|
!
|
|
! rhog(g) = total (smooth + US) charge density in G-space
|
|
!
|
|
DO ig = 1, ng
|
|
rhog(ig,iss)=rhog(ig,iss)+v(np(ig))
|
|
END DO
|
|
|
|
!
|
|
IF(iprsta.GT.1) WRITE( stdout,'(a,2f12.8)') &
|
|
& ' rhov: n_v(g=0) = ',omega*DBLE(rhog(1,iss))
|
|
!
|
|
ELSE
|
|
!
|
|
! nspin=2: two fft at a time, one for spin up and one for spin down
|
|
!
|
|
isup=1
|
|
isdw=2
|
|
isa=1
|
|
DO is=1,nvb
|
|
DO ia=1,na(is)
|
|
#ifdef __PARA
|
|
IF ( dfftb%np3( isa ) <= 0 ) go to 25
|
|
#endif
|
|
DO iss=1,2
|
|
qgbt(:,iss) = (0.d0, 0.d0)
|
|
DO iv=1,nh(is)
|
|
DO jv=iv,nh(is)
|
|
ijv = (jv-1)*jv/2 + iv
|
|
sumrho=rhovan(ijv,isa,iss)
|
|
IF(iv.NE.jv) sumrho=2.d0*sumrho
|
|
DO ig=1,ngb
|
|
qgbt(ig,iss)=qgbt(ig,iss)+sumrho*qgb(ig,ijv,is)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! add structure factor
|
|
!
|
|
qv(:) = (0.d0, 0.d0)
|
|
DO ig=1,ngb
|
|
qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1) &
|
|
& + ci* eigrb(ig,isa)*qgbt(ig,2)
|
|
qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1)) &
|
|
& + ci* CONJG(eigrb(ig,isa)*qgbt(ig,2))
|
|
END DO
|
|
!
|
|
CALL invfft('Box',qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isa)
|
|
!
|
|
! qv is the now the US augmentation charge for atomic species is
|
|
! and atom ia: real(qv)=spin up, imag(qv)=spin down
|
|
!
|
|
IF(iprsta.GT.2) THEN
|
|
ca = SUM(qv)
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: up g-space = ', &
|
|
& omegab*DBLE(qgbt(1,1))
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: up r-sp = ', &
|
|
& omegab*DBLE(ca)/(nr1b*nr2b*nr3b)
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: dw g-space = ', &
|
|
& omegab*DBLE(qgbt(1,2))
|
|
WRITE( stdout,'(a,f12.8)') ' rhov: dw r-sp = ', &
|
|
& omegab*AIMAG(ca)/(nr1b*nr2b*nr3b)
|
|
ENDIF
|
|
!
|
|
! add qv(r) to v(r), in real space on the dense grid
|
|
!
|
|
CALL box2grid2(irb(1,isa),qv,v)
|
|
25 isa=isa+1
|
|
!
|
|
END DO
|
|
END DO
|
|
!
|
|
DO ir=1,nnr
|
|
rhor(ir,isup)=rhor(ir,isup)+DBLE(v(ir))
|
|
rhor(ir,isdw)=rhor(ir,isdw)+AIMAG(v(ir))
|
|
END DO
|
|
!
|
|
IF(iprsta.GT.2) THEN
|
|
ca = SUM(v)
|
|
CALL mp_sum( ca, intra_image_comm )
|
|
WRITE( stdout,'(a,2f12.8)') 'rhov:in n_v ',omega*ca/(nr1*nr2*nr3)
|
|
ENDIF
|
|
!
|
|
CALL fwfft('Dense',v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
|
|
!
|
|
IF(iprsta.GT.2) THEN
|
|
WRITE( stdout,*) 'rhov: smooth up',omega*rhog(1,isup)
|
|
WRITE( stdout,*) 'rhov: smooth dw',omega*rhog(1,isdw)
|
|
WRITE( stdout,*) 'rhov: vander up',omega*DBLE(v(1))
|
|
WRITE( stdout,*) 'rhov: vander dw',omega*AIMAG(v(1))
|
|
WRITE( stdout,*) 'rhov: all up', &
|
|
& omega*(rhog(1,isup)+DBLE(v(1)))
|
|
WRITE( stdout,*) 'rhov: all dw', &
|
|
& omega*(rhog(1,isdw)+AIMAG(v(1)))
|
|
ENDIF
|
|
!
|
|
DO ig=1,ng
|
|
fp= v(np(ig)) + v(nm(ig))
|
|
fm= v(np(ig)) - v(nm(ig))
|
|
rhog(ig,isup)=rhog(ig,isup) + 0.5d0*CMPLX(DBLE(fp),AIMAG(fm))
|
|
rhog(ig,isdw)=rhog(ig,isdw) + 0.5d0*CMPLX(AIMAG(fp),-DBLE(fm))
|
|
END DO
|
|
|
|
!
|
|
IF(iprsta.GT.2) WRITE( stdout,'(a,2f12.8)') &
|
|
& ' rhov: n_v(g=0) up = ',omega*DBLE (rhog(1,isup))
|
|
IF(iprsta.GT.2) WRITE( stdout,'(a,2f12.8)') &
|
|
& ' rhov: n_v(g=0) down = ',omega*DBLE(rhog(1,isdw))
|
|
!
|
|
ENDIF
|
|
|
|
DEALLOCATE(qgbt)
|
|
DEALLOCATE( v )
|
|
DEALLOCATE( qv )
|
|
|
|
CALL stop_clock( 'rhov' )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE rhov
|
|
!
|
|
!
|
|
!-------------------------------------------------------------------------
|
|
SUBROUTINE s_wfc(n_atomic_wfc1,becwfc,betae,wfc,swfc) !@@@@ Changed n_atomic_wfc to n_atomic_wfc1
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! input: wfc, becwfc=<wfc|beta>, betae=|beta>
|
|
! output: swfc=S|wfc>
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE ions_base, ONLY: na
|
|
USE cvan, ONLY: nvb, ish
|
|
USE uspp, ONLY: nhsa => nkb, nhsavb=>nkbus, qq
|
|
USE uspp_param, ONLY: nh
|
|
USE gvecw, ONLY: ngw
|
|
USE constants, ONLY: pi, fpi
|
|
IMPLICIT NONE
|
|
! input
|
|
INTEGER, INTENT(in) :: n_atomic_wfc1
|
|
COMPLEX(DP), INTENT(in) :: betae(ngw,nhsa), &
|
|
& wfc(ngw,n_atomic_wfc1)
|
|
REAL(DP), INTENT(in) :: becwfc(nhsa,n_atomic_wfc1)
|
|
! output
|
|
COMPLEX(DP), INTENT(out):: swfc(ngw,n_atomic_wfc1)
|
|
! local
|
|
INTEGER is, iv, jv, ia, inl, jnl, i
|
|
REAL(DP) qtemp(nhsavb,n_atomic_wfc1)
|
|
!
|
|
swfc = wfc
|
|
!
|
|
IF (nvb.GT.0) THEN
|
|
qtemp=0.d0
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
IF(ABS(qq(iv,jv,is)).GT.1.e-5) THEN
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
DO i=1,n_atomic_wfc1
|
|
qtemp(inl,i) = qtemp(inl,i) + &
|
|
& qq(iv,jv,is)*becwfc(jnl,i)
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! CALL MXMA (betae,1,2*ngw,qtemp,1,nhsavb,swfc,1, &
|
|
! & 2*ngw,2*ngw,nhsavb,n_atomic_wfc1)
|
|
!
|
|
CALL DGEMM &
|
|
('N','N',2*ngw,n_atomic_wfc1,nhsavb,1.0d0,betae,2*ngw,&
|
|
qtemp,nhsavb,1.0d0,swfc,2*ngw)
|
|
!
|
|
END IF
|
|
!
|
|
! swfc=swfc+wfc
|
|
!
|
|
RETURN
|
|
END SUBROUTINE s_wfc
|
|
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE spinsq (c,bec,rhor)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! estimate of <S^2>=s(s+1) in two different ways.
|
|
! 1) using as many-body wavefunction a single Slater determinant
|
|
! constructed with Kohn-Sham orbitals:
|
|
!
|
|
! <S^2> = (Nup-Ndw)/2 * (Nup-Ndw)/2+1) + Ndw -
|
|
! \sum_up\sum_dw < psi_up | psi_dw >
|
|
!
|
|
! where Nup, Ndw = number of up and down states, the sum is over
|
|
! occupied states. Not suitable for fractionary occupancy.
|
|
! In the ultrasoft scheme (c is the smooth part of \psi):
|
|
!
|
|
! < psi_up | psi_dw > = \sum_G c*_up(G) c_dw(G) +
|
|
! \int Q_ij <c_up|beta_i><beta_j|c_dw>
|
|
!
|
|
! This is the usual formula, unsuitable for fractionary occupancy.
|
|
! 2) using the "LSD model" of Wang, Becke, Smith, JCP 102, 3477 (1995):
|
|
!
|
|
! <S^2> = (Nup-Ndw)/2 * (Nup-Ndw)/2+1) + Ndw -
|
|
! \int max(rhoup(r),rhodw(r)) dr
|
|
!
|
|
! Requires on input: c=psi, bec=<c|beta>, rhoup(r), rhodw(r)
|
|
! Assumes real psi, with only half G vectors.
|
|
!
|
|
USE electrons_base, ONLY: nx => nbspx, n => nbsp, iupdwn, nupdwn, f, nel, nspin
|
|
USE io_global, ONLY: stdout
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE mp, ONLY: mp_sum
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3, &
|
|
nnr => nnrx
|
|
USE cell_base, ONLY: omega
|
|
USE cvan, ONLY: nvb, ish
|
|
USE uspp, ONLY: nhsa => nkb, nhsavb=>nkbus, qq
|
|
USE uspp_param, ONLY: nh
|
|
USE ions_base, ONLY: na
|
|
!
|
|
IMPLICIT NONE
|
|
! input
|
|
REAL(8) bec(nhsa,n), rhor(nnr,nspin)
|
|
COMPLEX(8) c(ngw,nx)
|
|
! local variables
|
|
INTEGER nup, ndw, ir, i, j, jj, ig, ia, is, iv, jv, inl, jnl
|
|
REAL(8) spin0, spin1, spin2, fup, fdw
|
|
REAL(8), ALLOCATABLE:: overlap(:,:), temp(:)
|
|
LOGICAL frac
|
|
!
|
|
!
|
|
IF (nspin.EQ.1) RETURN
|
|
!
|
|
! find spin-up and spin-down states
|
|
!
|
|
fup = 0.0d0
|
|
DO i=iupdwn(1),nupdwn(1)
|
|
fup = fup + f(i)
|
|
END DO
|
|
nup = NINT(fup)
|
|
ndw = nel(1)+nel(2) - nup
|
|
!
|
|
! paranoid checks
|
|
!
|
|
frac= ABS(fup-nup).GT.1.0d-6
|
|
fup = 0.0d0
|
|
DO i=1,nup
|
|
fup = fup + f(i)
|
|
END DO
|
|
frac=frac.OR.ABS(fup-nup).GT.1.0d-6
|
|
fdw = 0.0d0
|
|
DO j=iupdwn(2),iupdwn(2)-1+ndw
|
|
fdw = fdw + f(j)
|
|
END DO
|
|
frac=frac.OR.ABS(fdw-ndw).GT.1.0d-6
|
|
!
|
|
spin0 = ABS(fup-fdw)/2.d0 * ( ABS(fup-fdw)/2.d0 + 1.d0 ) + fdw
|
|
!
|
|
! Becke's formula for spin polarization
|
|
!
|
|
spin1 = 0.0d0
|
|
DO ir=1,nnr
|
|
spin1 = spin1 - MIN(rhor(ir,1),rhor(ir,2))
|
|
END DO
|
|
CALL mp_sum( spin1, intra_image_comm )
|
|
spin1 = spin0 + omega/(nr1*nr2*nr3)*spin1
|
|
IF (frac) THEN
|
|
WRITE( stdout,'(/'' Spin contamination: s(s+1)='',f5.2,'' (Becke) '',&
|
|
& f5.2,'' (expected)'')') &
|
|
& spin1, ABS(fup-fdw)/2.d0*(ABS(fup-fdw)/2.d0+1.d0)
|
|
RETURN
|
|
END IF
|
|
!
|
|
! Slater formula, smooth contribution to < psi_up | psi_dw >
|
|
!
|
|
ALLOCATE (overlap(nup,ndw))
|
|
ALLOCATE (temp(ngw))
|
|
DO j=1,ndw
|
|
jj=j+iupdwn(2)-1
|
|
DO i=1,nup
|
|
overlap(i,j)=0.d0
|
|
DO ig=1,ngw
|
|
temp(ig)=DBLE(CONJG(c(ig,i))*c(ig,jj))
|
|
END DO
|
|
overlap(i,j) = 2.d0*SUM(temp)
|
|
IF (gstart == 2) overlap(i,j) = overlap(i,j) - temp(1)
|
|
END DO
|
|
END DO
|
|
DEALLOCATE (temp)
|
|
CALL mp_sum( overlap, intra_image_comm )
|
|
DO j=1,ndw
|
|
jj=j+iupdwn(2)-1
|
|
DO i=1,nup
|
|
!
|
|
! vanderbilt contribution to < psi_up | psi_dw >
|
|
!
|
|
DO is=1,nvb
|
|
DO iv=1,nh(is)
|
|
DO jv=1,nh(is)
|
|
IF(ABS(qq(iv,jv,is)).GT.1.e-5) THEN
|
|
DO ia=1,na(is)
|
|
inl=ish(is)+(iv-1)*na(is)+ia
|
|
jnl=ish(is)+(jv-1)*na(is)+ia
|
|
overlap(i,j) = overlap(i,j) + &
|
|
& qq(iv,jv,is)*bec(inl,i)*bec(jnl,jj)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
spin2 = spin0
|
|
DO j=1,ndw
|
|
DO i=1,nup
|
|
spin2 = spin2 - overlap(i,j)**2
|
|
END DO
|
|
END DO
|
|
!
|
|
DEALLOCATE (overlap)
|
|
!
|
|
WRITE( stdout,'(/" Spin contamination: s(s+1)=",f5.2," (Slater) ", &
|
|
& f5.2," (Becke) ",f5.2," (expected)")') &
|
|
& spin2,spin1, ABS(fup-fdw)/2.d0*(ABS(fup-fdw)/2.d0+1.d0)
|
|
!
|
|
RETURN
|
|
END SUBROUTINE spinsq
|
|
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE vofrho( nfi, rhor, rhog, rhos, rhoc, tfirst, tlast, &
|
|
& ei1, ei2, ei3, irb, eigrb, sfac, tau0, fion )
|
|
!-----------------------------------------------------------------------
|
|
! computes: the one-particle potential v in real space,
|
|
! the total energy etot,
|
|
! the forces fion acting on the ions,
|
|
! the derivative of total energy to cell parameters h
|
|
! rhor input : electronic charge on dense real space grid
|
|
! (plus core charge if present)
|
|
! rhog input : electronic charge in g space (up to density cutoff)
|
|
! rhos input : electronic charge on smooth real space grid
|
|
! rhor output: total potential on dense real space grid
|
|
! rhos output: total potential on smooth real space grid
|
|
!
|
|
USE kinds, ONLY: dp
|
|
USE control_flags, ONLY: iprint, iprsta, thdyn, tpre, tfor, &
|
|
tprnfor, iesr
|
|
USE io_global, ONLY: stdout
|
|
USE ions_base, ONLY: nsp, na, nat, rcmax
|
|
USE gvecs
|
|
USE gvecp, ONLY: ng => ngm
|
|
USE cell_base, ONLY: omega, r_to_s
|
|
USE cell_base, ONLY: a1, a2, a3, tpiba2, h, ainv
|
|
USE reciprocal_vectors, ONLY: gstart, g, gx
|
|
USE recvecs_indexes, ONLY: np, nm
|
|
USE grid_dimensions, ONLY: nr1, nr2, nr3, &
|
|
nr1x, nr2x, nr3x, nnr => nnrx
|
|
USE smooth_grid_dimensions, ONLY: nr1s, nr2s, nr3s, &
|
|
nr1sx, nr2sx, nr3sx, nnrsx
|
|
USE electrons_base, ONLY: nspin
|
|
USE constants, ONLY: pi, fpi, au_gpa
|
|
USE energies, ONLY: etot, eself, enl, ekin, epseu, esr, eht, exc
|
|
USE local_pseudo, ONLY: vps, dvps, rhops
|
|
USE core, ONLY: nlcc_any
|
|
USE gvecb
|
|
USE dener, ONLY: detot, dekin, dps, dh, dsr, dxc, denl, &
|
|
detot6, dekin6, dps6, dh6, dsr6, dxc6, denl6
|
|
USE derho
|
|
USE mp, ONLY: mp_sum
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE funct, ONLY: dft_is_meta
|
|
USE pres_ai_mod, ONLY: abivol, abisur, v_vol, P_ext, volclu, &
|
|
Surf_t, surfclu
|
|
USE cp_interfaces, ONLY: fwfft, invfft, self_vofhar
|
|
USE sic_module, ONLY: self_interaction, sic_epsilon, sic_alpha
|
|
USE energies, ONLY: self_exc, self_ehte
|
|
USE cp_interfaces, ONLY: pseudo_stress, compute_gagb, stress_hartree, &
|
|
add_drhoph, stress_local
|
|
!@@@@@
|
|
USE ldaU, ONLY: e_hubbard
|
|
!@@@@@
|
|
IMPLICIT NONE
|
|
!
|
|
LOGICAL :: tlast, tfirst
|
|
INTEGER :: nfi
|
|
REAL(DP) rhor(nnr,nspin), rhos(nnrsx,nspin), fion(3,nat)
|
|
REAL(DP) rhoc(nnr), tau0(3,nat)
|
|
COMPLEX(DP) ei1(-nr1:nr1,nat), ei2(-nr2:nr2,nat), &
|
|
& ei3(-nr3:nr3,nat), eigrb(ngb,nat), &
|
|
& rhog(ng,nspin), sfac(ngs,nsp)
|
|
!
|
|
INTEGER irb(3,nat)
|
|
!
|
|
INTEGER iss, isup, isdw, ig, ir, i, j, k, ij, is, ia
|
|
REAL(DP) vave, ebac, wz, eh, ehpre
|
|
COMPLEX(DP) fp, fm, ci, drhop
|
|
COMPLEX(DP), ALLOCATABLE :: rhotmp(:), vtemp(:)
|
|
! COMPLEX(DP), ALLOCATABLE :: drhotmp(:,:,:)
|
|
COMPLEX(DP), ALLOCATABLE :: drhot(:,:)
|
|
COMPLEX(DP), ALLOCATABLE :: v(:), vs(:)
|
|
REAL(DP), ALLOCATABLE :: gagb(:,:)
|
|
!
|
|
REAL(DP), ALLOCATABLE :: fion1( :, : )
|
|
REAL(DP), ALLOCATABLE :: stmp( :, : )
|
|
!
|
|
COMPLEX(DP), ALLOCATABLE :: self_vloc(:)
|
|
COMPLEX(DP) :: self_rhoeg
|
|
REAL(DP) :: self_ehtet, fpibg
|
|
LOGICAL :: ttsic
|
|
REAL(DP) :: detmp( 3, 3 ), desr( 6 ), deps( 6 )
|
|
REAL(DP) :: detmp2( 3, 3 )
|
|
REAL(DP) :: ht( 3, 3 )
|
|
REAL(DP) :: deht( 6 )
|
|
!
|
|
INTEGER, DIMENSION(6), PARAMETER :: alpha = (/ 1,2,3,2,3,3 /)
|
|
INTEGER, DIMENSION(6), PARAMETER :: beta = (/ 1,1,1,2,2,3 /)
|
|
|
|
! ... dalbe(:) = delta( alpha(:), beta(:) )
|
|
REAL(DP), DIMENSION(6), PARAMETER :: dalbe = &
|
|
(/ 1.0_DP, 0.0_DP, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP /)
|
|
|
|
|
|
|
|
CALL start_clock( 'vofrho' )
|
|
|
|
ci = ( 0.0d0, 1.0d0 )
|
|
!
|
|
! wz = factor for g.neq.0 because of c*(g)=c(-g)
|
|
!
|
|
wz = 2.0d0
|
|
!
|
|
ht = TRANSPOSE( h )
|
|
!
|
|
ALLOCATE( v( nnr ) )
|
|
ALLOCATE( vs( nnrsx ) )
|
|
ALLOCATE( vtemp( ng ) )
|
|
ALLOCATE( rhotmp( ng ) )
|
|
!
|
|
IF ( tpre ) THEN
|
|
ALLOCATE( drhot( ng, 6 ) )
|
|
ALLOCATE( gagb( 6, ng ) )
|
|
CALL compute_gagb( gagb, gx, ng, tpiba2 )
|
|
END IF
|
|
!
|
|
! ab-initio pressure and surface tension contributions to the potential
|
|
!
|
|
if (abivol.or.abisur) call vol_clu(rhor,rhog,sfac,nfi)
|
|
!
|
|
ttsic = ( ABS( self_interaction ) /= 0 )
|
|
!
|
|
IF( ttsic ) ALLOCATE( self_vloc( ng ) )
|
|
!
|
|
! first routine in which fion is calculated: annihilation
|
|
!
|
|
fion = 0.d0
|
|
!
|
|
! forces on ions, ionic term in real space
|
|
!
|
|
IF( tprnfor .OR. tfor .OR. tfirst .OR. tpre ) THEN
|
|
!
|
|
ALLOCATE( stmp( 3, nat ) )
|
|
!
|
|
CALL r_to_s( tau0, stmp, na, nsp, ainv )
|
|
!
|
|
CALL vofesr( iesr, esr, dsr6, fion, stmp, tpre, h )
|
|
!
|
|
call mp_sum( fion, intra_image_comm )
|
|
!
|
|
DEALLOCATE( stmp )
|
|
!
|
|
END IF
|
|
!
|
|
rhotmp( 1:ng ) = rhog( 1:ng, 1 )
|
|
!
|
|
|
|
IF( tpre ) THEN
|
|
DO ij = 1, 6
|
|
i = alpha( ij )
|
|
j = beta( ij )
|
|
drhot( :, ij ) = 0.0d0
|
|
DO k = 1, 3
|
|
drhot( :, ij ) = drhot( :, ij ) + drhog( :, 1, i, k ) * ht( k, j )
|
|
END DO
|
|
END DO
|
|
END IF
|
|
!
|
|
IF( nspin == 2 ) THEN
|
|
rhotmp( 1:ng ) = rhotmp( 1:ng ) + rhog( 1:ng, 2 )
|
|
IF(tpre)THEN
|
|
DO ij = 1, 6
|
|
i = alpha( ij )
|
|
j = beta( ij )
|
|
DO k = 1, 3
|
|
drhot( :, ij ) = drhot( :, ij ) + drhog( :, 2, i, k ) * ht( k, j )
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
END IF
|
|
!
|
|
! calculation local potential energy
|
|
!
|
|
vtemp=(0.d0,0.d0)
|
|
DO is=1,nsp
|
|
DO ig=1,ngs
|
|
vtemp(ig)=vtemp(ig)+CONJG(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
|
|
END DO
|
|
END DO
|
|
|
|
epseu = wz * DBLE(SUM(vtemp))
|
|
IF (gstart == 2) epseu=epseu-vtemp(1)
|
|
CALL mp_sum( epseu, intra_image_comm )
|
|
|
|
epseu = epseu * omega
|
|
|
|
!
|
|
IF( tpre ) THEN
|
|
!
|
|
CALL stress_local( dps6, epseu, gagb, sfac, rhotmp, drhot, omega )
|
|
!
|
|
END IF
|
|
!
|
|
!
|
|
! calculation hartree energy
|
|
!
|
|
!
|
|
self_ehtet = 0.d0
|
|
!
|
|
IF( ttsic ) self_vloc = 0.d0
|
|
|
|
DO is=1,nsp
|
|
DO ig=1,ngs
|
|
rhotmp(ig)=rhotmp(ig)+sfac(ig,is)*rhops(ig,is)
|
|
END DO
|
|
END DO
|
|
!
|
|
IF (gstart == 2) vtemp(1)=0.0d0
|
|
DO ig = gstart, ng
|
|
vtemp(ig) = CONJG( rhotmp( ig ) ) * rhotmp( ig ) / g( ig )
|
|
END DO
|
|
!
|
|
eh = DBLE( SUM( vtemp ) ) * wz * 0.5d0 * fpi / tpiba2
|
|
!
|
|
IF ( ttsic ) THEN
|
|
!
|
|
CALL self_vofhar( .false., self_ehte, self_vloc, rhog, omega, h )
|
|
!
|
|
eh = eh - self_ehte / omega
|
|
|
|
CALL mp_sum( self_ehte, intra_image_comm )
|
|
!
|
|
END IF
|
|
!
|
|
CALL mp_sum( eh, intra_image_comm )
|
|
!
|
|
IF(tpre) THEN
|
|
!
|
|
CALL add_drhoph( drhot, sfac, gagb )
|
|
!
|
|
CALL stress_hartree(dh6, eh*omega, sfac, rhotmp, drhot, gagb, omega )
|
|
!
|
|
END IF
|
|
!
|
|
IF(tpre) THEN
|
|
DEALLOCATE( drhot )
|
|
END IF
|
|
!
|
|
! forces on ions, ionic term in reciprocal space
|
|
!
|
|
ALLOCATE( fion1( 3, nat ) )
|
|
!
|
|
fion1 = 0.d0
|
|
!
|
|
IF( tprnfor .OR. tfor .OR. tpre) THEN
|
|
CALL force_ps(rhotmp,rhog,vtemp,ei1,ei2,ei3,fion1)
|
|
END IF
|
|
|
|
!
|
|
! calculation hartree + local pseudo potential
|
|
!
|
|
!
|
|
IF (gstart == 2) vtemp(1)=(0.d0,0.d0)
|
|
DO ig=gstart,ng
|
|
vtemp(ig)=rhotmp(ig)*fpi/(tpiba2*g(ig))
|
|
END DO
|
|
!
|
|
DO is=1,nsp
|
|
DO ig=1,ngs
|
|
vtemp(ig)=vtemp(ig)+sfac(ig,is)*vps(ig,is)
|
|
END DO
|
|
END DO
|
|
!
|
|
! vtemp = v_loc(g) + v_h(g)
|
|
!
|
|
! ===================================================================
|
|
! calculation exchange and correlation energy and potential
|
|
! -------------------------------------------------------------------
|
|
IF ( nlcc_any ) CALL add_cc( rhoc, rhog, rhor )
|
|
!
|
|
CALL exch_corr_h( nspin, rhog, rhor, rhoc, sfac, exc, dxc, self_exc )
|
|
|
|
!
|
|
! rhor contains the xc potential in r-space
|
|
!
|
|
! ===================================================================
|
|
! fourier transform of xc potential to g-space (dense grid)
|
|
! -------------------------------------------------------------------
|
|
!
|
|
IF( nspin == 1 ) THEN
|
|
iss = 1
|
|
if (abivol.or.abisur) then
|
|
do ir=1,nnr
|
|
v(ir)=CMPLX( rhor( ir, iss ) + v_vol( ir ), 0.d0 )
|
|
end do
|
|
else
|
|
do ir=1,nnr
|
|
v(ir)=CMPLX( rhor( ir, iss ), 0.d0 )
|
|
end do
|
|
end if
|
|
!
|
|
! v_xc(r) --> v_xc(g)
|
|
!
|
|
CALL fwfft( 'Dense', v, nr1, nr2, nr3, nr1x, nr2x, nr3x )
|
|
!
|
|
DO ig = 1, ng
|
|
rhog( ig, iss ) = vtemp(ig) + v( np( ig ) )
|
|
END DO
|
|
!
|
|
! v_tot(g) = (v_tot(g) - v_xc(g)) +v_xc(g)
|
|
! rhog contains the total potential in g-space
|
|
!
|
|
ELSE
|
|
isup=1
|
|
isdw=2
|
|
if (abivol.or.abisur) then
|
|
do ir=1,nnr
|
|
v(ir)=CMPLX(rhor(ir,isup)+v_vol(ir),rhor(ir,isdw)+v_vol(ir))
|
|
end do
|
|
else
|
|
do ir=1,nnr
|
|
v(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw))
|
|
end do
|
|
end if
|
|
CALL fwfft('Dense',v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
|
|
DO ig=1,ng
|
|
fp=v(np(ig))+v(nm(ig))
|
|
fm=v(np(ig))-v(nm(ig))
|
|
IF( ttsic ) THEN
|
|
rhog(ig,isup)=vtemp(ig)-self_vloc(ig) +0.5d0*CMPLX( DBLE(fp),AIMAG(fm))
|
|
rhog(ig,isdw)=vtemp(ig)+self_vloc(ig) +0.5d0*CMPLX(AIMAG(fp),-DBLE(fm))
|
|
ELSE
|
|
rhog(ig,isup)=vtemp(ig)+0.5d0*CMPLX( DBLE(fp),AIMAG(fm))
|
|
rhog(ig,isdw)=vtemp(ig)+0.5d0*CMPLX(AIMAG(fp),-DBLE(fm))
|
|
ENDIF
|
|
END DO
|
|
ENDIF
|
|
|
|
!
|
|
! rhog contains now the total (local+Hartree+xc) potential in g-space
|
|
!
|
|
IF( tprnfor .OR. tfor ) THEN
|
|
|
|
IF ( nlcc_any ) CALL force_cc( irb, eigrb, rhor, fion1 )
|
|
|
|
CALL mp_sum( fion1, intra_image_comm )
|
|
!
|
|
! add g-space ionic and core correction contributions to fion
|
|
!
|
|
fion = fion + fion1
|
|
|
|
END IF
|
|
|
|
DEALLOCATE( fion1 )
|
|
!
|
|
IF( ttsic ) DEALLOCATE( self_vloc )
|
|
!
|
|
! ===================================================================
|
|
! fourier transform of total potential to r-space (dense grid)
|
|
! -------------------------------------------------------------------
|
|
v(:) = (0.d0, 0.d0)
|
|
IF(nspin.EQ.1) THEN
|
|
iss=1
|
|
DO ig=1,ng
|
|
v(np(ig))=rhog(ig,iss)
|
|
v(nm(ig))=CONJG(rhog(ig,iss))
|
|
END DO
|
|
!
|
|
! v(g) --> v(r)
|
|
!
|
|
CALL invfft('Dense',v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
|
|
!
|
|
DO ir=1,nnr
|
|
rhor(ir,iss)=DBLE(v(ir))
|
|
END DO
|
|
!
|
|
! calculation of average potential
|
|
!
|
|
vave=SUM(rhor(:,iss))/DBLE(nr1*nr2*nr3)
|
|
ELSE
|
|
isup=1
|
|
isdw=2
|
|
DO ig=1,ng
|
|
v(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
|
|
v(nm(ig))=CONJG(rhog(ig,isup)) +ci*CONJG(rhog(ig,isdw))
|
|
END DO
|
|
!
|
|
CALL invfft('Dense',v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
|
|
DO ir=1,nnr
|
|
rhor(ir,isup)= DBLE(v(ir))
|
|
rhor(ir,isdw)=AIMAG(v(ir))
|
|
END DO
|
|
!
|
|
! calculation of average potential
|
|
!
|
|
vave=(SUM(rhor(:,isup))+SUM(rhor(:,isdw))) / 2.0d0 / DBLE( nr1 * nr2 * nr3 )
|
|
ENDIF
|
|
|
|
CALL mp_sum( vave, intra_image_comm )
|
|
|
|
!
|
|
! fourier transform of total potential to r-space (smooth grid)
|
|
!
|
|
vs (:) = (0.d0, 0.d0)
|
|
!
|
|
IF(nspin.EQ.1)THEN
|
|
!
|
|
iss=1
|
|
DO ig=1,ngs
|
|
vs(nms(ig))=CONJG(rhog(ig,iss))
|
|
vs(nps(ig))=rhog(ig,iss)
|
|
END DO
|
|
!
|
|
CALL invfft('Smooth',vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
|
|
!
|
|
DO ir=1,nnrsx
|
|
rhos(ir,iss)=DBLE(vs(ir))
|
|
END DO
|
|
!
|
|
ELSE
|
|
!
|
|
isup=1
|
|
isdw=2
|
|
DO ig=1,ngs
|
|
vs(nps(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
|
|
vs(nms(ig))=CONJG(rhog(ig,isup)) +ci*CONJG(rhog(ig,isdw))
|
|
END DO
|
|
!
|
|
CALL invfft('Smooth',vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
|
|
!
|
|
DO ir=1,nnrsx
|
|
rhos(ir,isup)= DBLE(vs(ir))
|
|
rhos(ir,isdw)=AIMAG(vs(ir))
|
|
END DO
|
|
!
|
|
ENDIF
|
|
|
|
IF( dft_is_meta() ) CALL vofrho_meta( v, vs ) !METAGGA
|
|
|
|
ebac = 0.0d0
|
|
!
|
|
eht = eh * omega + esr - eself
|
|
!
|
|
! etot is the total energy ; ekin, enl were calculated in rhoofr
|
|
!
|
|
etot = ekin + eht + epseu + enl + exc + ebac +e_hubbard
|
|
!
|
|
if (abivol) etot = etot + P_ext*volclu
|
|
if (abisur) etot = etot + Surf_t*surfclu
|
|
!
|
|
IF( tpre ) THEN
|
|
!
|
|
detot6 = dekin6 + dh6 + dps6 + dsr6
|
|
!
|
|
call mp_sum( detot6, intra_image_comm )
|
|
!
|
|
DO k = 1, 6
|
|
detmp( alpha(k), beta(k) ) = detot6(k)
|
|
detmp( beta(k), alpha(k) ) = detmp( alpha(k), beta(k) )
|
|
END DO
|
|
!
|
|
detot = MATMUL( detmp(:,:), TRANSPOSE( ainv(:,:) ) )
|
|
!
|
|
detot = detot + denl + dxc
|
|
!
|
|
END IF
|
|
!
|
|
!
|
|
CALL stop_clock( 'vofrho' )
|
|
!
|
|
!
|
|
IF ( tpre ) THEN
|
|
!
|
|
DEALLOCATE( gagb )
|
|
!
|
|
IF( ( iprsta >= 2 ) .AND. ( MOD( nfi - 1, iprint) == 0 ) ) THEN
|
|
!
|
|
WRITE( stdout,*)
|
|
WRITE( stdout,*) "From vofrho:"
|
|
WRITE( stdout,*) "cell parameters h"
|
|
WRITE( stdout,5555) (a1(i),a2(i),a3(i),i=1,3)
|
|
!
|
|
WRITE( stdout,*)
|
|
WRITE( stdout,*) "derivative of e(tot)"
|
|
WRITE( stdout,5555) ((detot(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( detot, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
!
|
|
WRITE( stdout,*)
|
|
WRITE( stdout,*) "derivative of e(kin)"
|
|
WRITE( stdout,5555) ((dekin(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( dekin, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
!
|
|
WRITE( stdout,*) "derivative of e(h)"
|
|
WRITE( stdout,5555) ((dh(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( dh, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
!
|
|
WRITE( stdout,*) "derivative of e(sr)"
|
|
WRITE( stdout,5555) ((dsr(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( dsr, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
!
|
|
WRITE( stdout,*) "derivative of e(ps)"
|
|
WRITE( stdout,5555) ((dps(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( dps, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
!
|
|
WRITE( stdout,*) "derivative of e(nl)"
|
|
WRITE( stdout,5555) ((denl(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( denl, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
!
|
|
WRITE( stdout,*) "derivative of e(xc)"
|
|
WRITE( stdout,5555) ((dxc(i,j),j=1,3),i=1,3)
|
|
WRITE( stdout,*) "kbar"
|
|
detmp = -1.0d0 * MATMUL( dxc, TRANSPOSE( h ) ) / omega * au_gpa * 10.0d0
|
|
WRITE( stdout,5555) ((detmp(i,j),j=1,3),i=1,3)
|
|
ENDIF
|
|
ENDIF
|
|
|
|
DEALLOCATE( rhotmp )
|
|
DEALLOCATE( vtemp )
|
|
DEALLOCATE( v )
|
|
DEALLOCATE( vs )
|
|
|
|
RETURN
|
|
|
|
5555 FORMAT(1x,f12.5,1x,f12.5,1x,f12.5/ &
|
|
& 1x,f12.5,1x,f12.5,1x,f12.5/ &
|
|
& 1x,f12.5,1x,f12.5,1x,f12.5//)
|
|
!
|
|
|
|
END SUBROUTINE vofrho
|
|
|
|
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
|
|
!-----------------------------------------------------------------------
|
|
subroutine ldaU_init
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
use ldaU, ONLY: n_atomic_wfc, atomwfc,lda_plus_u, Hubbard_U
|
|
use ldaU, ONLY: Hubbard_lmax, Hubbard_l, ns, vupsi
|
|
use input_parameters, ONLY: atom_label, lda_plus_u_ => lda_plus_u
|
|
use input_parameters, ONLY: Hubbard_U_ => Hubbard_U
|
|
use ions_base, only: na, nsp, nat
|
|
use gvecw, only: ngw
|
|
use electrons_base, only: nspin, nx => nbspx
|
|
USE atom, ONLY: nchi, lchi
|
|
!
|
|
implicit none
|
|
integer is, nb, l
|
|
integer, external :: set_Hubbard_l
|
|
|
|
! allocate vupsi
|
|
|
|
lda_plus_u = lda_plus_u_
|
|
|
|
allocate(vupsi(ngw,nx))
|
|
|
|
vupsi=(0.0,0.0)
|
|
! allocate(vpsi_con(ngw,nx)) ! step_constraint
|
|
n_atomic_wfc=0
|
|
|
|
do is=1,nsp
|
|
!
|
|
Hubbard_U( is ) = Hubbard_U_( is )/27.212
|
|
!
|
|
do nb = 1,nchi(is)
|
|
l = lchi(nb,is)
|
|
n_atomic_wfc = n_atomic_wfc + (2*l+1)*na(is)
|
|
end do
|
|
!
|
|
end do
|
|
! allocate(swfcatom(ngw,n_atomic_wfc))
|
|
!
|
|
allocate(atomwfc(ngw,n_atomic_wfc))
|
|
! call genatwfc(n_atomic_wfc,atomwfc)
|
|
if (lda_plus_u) then
|
|
Hubbard_lmax = -1
|
|
do is=1,nsp
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
! Hubbard_l(is)=2
|
|
Hubbard_l(is) = set_Hubbard_l( atom_label(is) )
|
|
Hubbard_lmax = max(Hubbard_lmax,Hubbard_l(is))
|
|
write (6,*) ' HUBBARD L FOR TYPE ',atom_label(is),' IS ',&
|
|
& Hubbard_l(is)
|
|
end if
|
|
end do
|
|
write (6,*) ' MAXIMUM HUBBARD L IS ', Hubbard_lmax
|
|
if (Hubbard_lmax.eq.-1) call errore &
|
|
& ('setup','lda_plus_u calculation but Hubbard_l not set',1)
|
|
end if
|
|
l = 2 * Hubbard_lmax + 1
|
|
allocate(ns(nat,nspin,l,l))
|
|
return
|
|
end subroutine ldaU_init
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
integer function set_Hubbard_l(psd) result (hubbard_l)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
implicit none
|
|
character*3 :: psd
|
|
!
|
|
! TRANSITION METALS
|
|
!
|
|
if (psd.eq.'V' .or. psd.eq.'Cr' .or. psd .eq.'Mn' .or. psd.eq.'Fe' .or. &
|
|
psd.eq.'Co' .or. psd.eq.'Ni' .or. psd .eq.'Cu'.or. psd .eq.'Fe1'.or. &
|
|
psd .eq.'Fe2' ) then
|
|
hubbard_l = 2
|
|
!
|
|
! RARE EARTHS
|
|
!
|
|
elseif (psd .eq.'Ce') then
|
|
hubbard_l = 3
|
|
!
|
|
! OTHER ELEMENTS
|
|
!
|
|
elseif (psd .eq.'H') then
|
|
hubbard_l = 0
|
|
elseif (psd .eq.'O') then
|
|
hubbard_l = 1
|
|
else
|
|
hubbard_l = -1
|
|
call errore ('set_Hubbard_l','pseudopotential not yet inserted', 1)
|
|
endif
|
|
return
|
|
end function set_Hubbard_l
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
subroutine new_ns(c,eigr,betae,hpsi,hpsi_con,forceh)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! This routine computes the on site occupation numbers of the Hubbard ions.
|
|
! It also calculates the contribution of the Hubbard Hamiltonian to the
|
|
! electronic potential and to the forces acting on ions.
|
|
!
|
|
use control_flags, ONLY: tfor
|
|
use kinds, ONLY: DP
|
|
use parameters, ONLY: natx, nsx
|
|
use ions_base, only: na, nat, nsp
|
|
use gvecw, only: ngw
|
|
use reciprocal_vectors, only: ng0 => gstart
|
|
USE uspp, ONLY: nhsa=>nkb
|
|
! use cvan
|
|
!@@@@@
|
|
USE atom, ONLY: nchi, lchi
|
|
! USE cell_base, ONLY: tpiba
|
|
use electrons_base, only: nspin, n => nbsp, nx => nbspx, ispin, f
|
|
!@@@@@
|
|
USE ldaU, ONLY: lda_plus_u, Hubbard_U, Hubbard_l
|
|
USE ldaU, ONLY: n_atomic_wfc, ns, e_hubbard
|
|
!
|
|
implicit none
|
|
#ifdef __PARA
|
|
include 'mpif.h'
|
|
#endif
|
|
integer, parameter :: ldmx = 7
|
|
complex(DP), intent(in) :: c(ngw,nx), eigr(ngw,nat), &
|
|
& betae(ngw,nhsa)
|
|
complex(DP), intent(out) :: hpsi(ngw,nx), hpsi_con(1,1)
|
|
real(DP) forceh(3,natx,nsx)
|
|
!
|
|
complex(DP), allocatable:: wfc(:,:), swfc(:,:),dphi(:,:,:), &
|
|
& spsi(:,:)
|
|
real(DP), allocatable :: becwfc(:,:), bp(:,:), &
|
|
& dbp(:,:,:), wdb(:,:,:)
|
|
real(DP), allocatable :: dns(:,:,:,:), force_con(:,:,:)
|
|
real(DP), allocatable :: e(:), z(:,:), &
|
|
& proj(:,:), temp(:)
|
|
real(DP), allocatable :: ftemp1(:), ftemp2(:)
|
|
real(DP) :: lambda(ldmx), somma, SSUM, ntot, &
|
|
& nsum, nsuma, x_value, g_value, &
|
|
& step_value
|
|
real(DP) :: f1 (ldmx, ldmx), vet (ldmx, ldmx)
|
|
integer is, ia, iat, nb, isp, l, m, m1, m2, k, i, counter, err, ig
|
|
integer iv, jv, inl, jnl,alpha,alpha_a,alpha_s,ipol
|
|
integer, allocatable :: offset (:,:)
|
|
complex(DP) :: tempsi
|
|
!
|
|
!
|
|
allocate(wfc(ngw,n_atomic_wfc))
|
|
allocate(ftemp1(ldmx))
|
|
allocate(ftemp2(ldmx))
|
|
!
|
|
! calculate wfc = atomic states
|
|
!
|
|
!!! call ewfc(eigr,n_atomic_wfc,wfc)
|
|
!
|
|
! calculate bec = <beta|wfc>
|
|
!
|
|
allocate(becwfc(nhsa,n_atomic_wfc))
|
|
!!! call nlsm1 (n_atomic_wfc,1,nsp,eigr,wfc,becwfc)
|
|
!
|
|
allocate(swfc(ngw,n_atomic_wfc))
|
|
!!! call s_wfc(n_atomic_wfc,becwfc,betae,wfc,swfc)
|
|
!
|
|
! calculate proj = <c|S|wfc>
|
|
!
|
|
allocate(proj(n,n_atomic_wfc))
|
|
CALL projwfc_hub( c, nx, eigr, betae, n, n_atomic_wfc, &
|
|
& wfc, becwfc, swfc, proj ) !@@
|
|
!
|
|
allocate(offset(nsp,nat))
|
|
counter = 0
|
|
do is = 1, nsp
|
|
do ia = 1, na(is)
|
|
do i = 1, nchi (is)
|
|
l = lchi (i, is)
|
|
if (l.eq.Hubbard_l(is)) offset (is,ia) = counter
|
|
counter = counter + 2 * l + 1
|
|
end do
|
|
end do
|
|
end do
|
|
if (counter.ne.n_atomic_wfc) &
|
|
& call errore ('new_ns','nstart<>counter',1)
|
|
ns(:,:,:,:) = 0.d0
|
|
iat = 0
|
|
do is = 1,nsp
|
|
do ia = 1,na(is)
|
|
iat = iat + 1
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
k = offset(is,ia)
|
|
do m1 = 1, 2*Hubbard_l(is) + 1
|
|
do m2 = m1, 2*Hubbard_l(is) + 1
|
|
do i = 1,n
|
|
! write(6,*) i,ispin(i),f(i)
|
|
ns(iat,ispin(i),m1,m2) = ns(iat,ispin(i),m1,m2) + &
|
|
& f(i) * proj(i,k+m2) * proj(i,k+m1)
|
|
end do
|
|
! ns(iat,:,m2,m1) = ns(iat,:,m1,m2)
|
|
ns(iat,1,m2,m1) = ns(iat,1,m1,m2)
|
|
ns(iat,2,m2,m1) = ns(iat,2,m1,m2)
|
|
end do
|
|
end do
|
|
end if
|
|
end do
|
|
end do
|
|
if (nspin.eq.1) ns = 0.5d0 * ns
|
|
! Contributions to total energy
|
|
e_hubbard = 0.d0
|
|
iat = 0
|
|
do is = 1,nsp
|
|
do ia = 1,na(is)
|
|
iat=iat + 1
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
k = offset(is,ia)
|
|
do isp = 1,nspin
|
|
do m1 = 1, 2*Hubbard_l(is) + 1
|
|
e_hubbard = e_hubbard + 0.5d0 * Hubbard_U(is) * &
|
|
& ns(iat,isp,m1,m1)
|
|
do m2 = 1, 2*Hubbard_l(is) + 1
|
|
e_hubbard = e_hubbard - 0.5d0 * Hubbard_U(is) * &
|
|
& ns(iat,isp,m1,m2) * ns(iat,isp,m2,m1)
|
|
end do
|
|
end do
|
|
end do
|
|
end if
|
|
end do
|
|
end do
|
|
if (nspin.eq.1) e_hubbard = 2.d0*e_hubbard
|
|
! if (nspin.eq.1) e_lambda = 2.d0*e_lambda
|
|
!
|
|
! Calculate the potential and forces on wavefunctions due to U
|
|
!
|
|
hpsi(:,:)=(0.d0,0.d0)
|
|
iat=0
|
|
do is = 1, nsp
|
|
do ia=1, na(is)
|
|
iat = iat + 1
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
do i=1, n
|
|
do m1 = 1, 2 * Hubbard_l(is) + 1
|
|
tempsi = proj (i,offset(is,ia)+m1)
|
|
do m2 = 1, 2 * Hubbard_l(is) + 1
|
|
tempsi = tempsi - 2.d0 * ns(iat,ispin(i),m1,m2)*&
|
|
& proj (i,offset(is,ia)+m2)
|
|
enddo
|
|
tempsi = tempsi * Hubbard_U(is)/2.d0*f(i)
|
|
call ZAXPY (ngw,tempsi,swfc(1,offset(is,ia)+m1),1, &
|
|
& hpsi(1,i),1)
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
!
|
|
! Calculate the potential and energy due to constraint
|
|
!
|
|
hpsi_con(:,:)=0.d0
|
|
!
|
|
! Calculate the contribution to forces on ions due to U and constraint
|
|
!
|
|
forceh=0.d0
|
|
if (tfor) then
|
|
allocate (bp(nhsa,n), dbp(nhsa,n,3), wdb(nhsa,n_atomic_wfc,3))
|
|
allocate(dns(nat,nspin,ldmx,ldmx))
|
|
allocate (spsi(ngw,n))
|
|
allocate(force_con(3,natx,nsx))
|
|
force_con=0.d0
|
|
!
|
|
call nlsm1 (n,1,nsp,eigr,c,bp)
|
|
call s_wfc(n,bp,betae,c,spsi)
|
|
call nlsm2(ngw,nhsa,n,eigr,c,dbp,.true.)
|
|
! call nlsm2_ns(eigr,c,dbp)
|
|
call nlsm2(ngw,nhsa,n_atomic_wfc,eigr,wfc,wdb,.true.)
|
|
! call nlsmat(eigr,wfc,wdb)
|
|
!
|
|
alpha=0
|
|
do alpha_s = 1, nsp
|
|
do alpha_a = 1, na(alpha_s)
|
|
alpha=alpha+1
|
|
do ipol = 1,3
|
|
call dndtau(alpha_a,alpha_s,becwfc,spsi,bp,dbp,wdb, &
|
|
& offset,c,wfc,eigr, &
|
|
& betae,proj, &
|
|
& ipol,dns)
|
|
iat=0
|
|
do is = 1, nsp
|
|
do ia=1, na(is)
|
|
iat = iat + 1
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
do isp = 1,nspin
|
|
do m2 = 1,2*Hubbard_l(is) + 1
|
|
forceh(ipol,alpha_a,alpha_s) = &
|
|
& forceh(ipol,alpha_a,alpha_s) - &
|
|
& Hubbard_U(is) * 0.5d0 * dns(iat,isp,m2,m2)
|
|
do m1 = 1,2*Hubbard_l(is) + 1
|
|
forceh(ipol,alpha_a,alpha_s) = &
|
|
& forceh(ipol,alpha_a,alpha_s) + &
|
|
& Hubbard_U(is)*ns(iat,isp,m2,m1)* &
|
|
& dns(iat,isp,m1,m2)
|
|
end do
|
|
end do
|
|
end do
|
|
end if
|
|
! Occupation constraint add here
|
|
end do
|
|
end do
|
|
end do
|
|
end do
|
|
end do
|
|
if (nspin.eq.1) then
|
|
forceh(:,:,:) = 2.d0 * forceh(:,:,:)
|
|
force_con(:,:,:) =2.d0 * force_con(:,:,:)
|
|
end if
|
|
!
|
|
deallocate ( wfc, becwfc, spsi, proj, offset, swfc, dns, bp, &
|
|
& dbp, wdb, force_con)
|
|
end if
|
|
return
|
|
end subroutine new_ns
|
|
!
|
|
!
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
subroutine write_ns
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! This routine computes the occupation numbers on atomic orbitals.
|
|
! It also write the occupation number in the output file.
|
|
!
|
|
USE kinds, only: DP
|
|
use electrons_base, only: nspin
|
|
use electrons_base, only: n => nbsp
|
|
use ions_base, only: na, nat, nsp
|
|
use gvecw, only: ngw
|
|
USE ldaU, ONLY: lda_plus_u, Hubbard_U, Hubbard_l
|
|
USE ldaU, ONLY: n_atomic_wfc, ns, e_hubbard
|
|
USE ldaU, ONLY: Hubbard_lmax
|
|
use parallel_toolkit, only : dspev_drv
|
|
|
|
implicit none
|
|
|
|
integer :: is, isp, ia, m1, m2, ldim, iat, err, k
|
|
! cpunter on atoms type
|
|
! counter on spin component
|
|
! counter on atoms
|
|
! counter on wavefn
|
|
! counters on d components
|
|
integer, parameter :: ldmx = 7
|
|
real(DP), allocatable :: ftemp1(:), ftemp2(:)
|
|
real(DP) :: f1 (ldmx * ldmx), vet (ldmx, ldmx)
|
|
real(DP) :: lambda (ldmx), nsum, nsuma, au
|
|
write (*,*) 'enter write_ns'
|
|
au=27.212
|
|
|
|
if ( 2 * Hubbard_lmax + 1 .gt. ldmx ) &
|
|
call errore ('write_ns', 'ldmx is too small', 1)
|
|
|
|
! if (step_con) then
|
|
! do isp=1,nspin
|
|
! write (6,'(6(a,i2,a,i2,a,f8.4,6x))') &
|
|
! ('A_con(',is,',',isp,') =', A_con(is,isp),is=1,nsp)
|
|
! enddo
|
|
! write (6,'(6(a,i2,a,f8.4,6x))') &
|
|
! ('sigma_con(',is,') =', sigma_con(is), is=1,nsp)
|
|
! write (6,'(6(a,i2,a,f8.4,6x))') &
|
|
! ('alpha_con(',is,') =', alpha_con(is), is=1,nsp)
|
|
! endif
|
|
write (6,'(6(a,i2,a,f8.4,6x))') &
|
|
('U(',is,') =', Hubbard_U(is) * au, is=1,nsp)
|
|
! write (6,'(6(a,i2,a,f8.4,6x))') &
|
|
! ('alpha(',is,') =', Hubbard_alpha(is) * au, is=1,nsp)
|
|
nsum = 0.d0
|
|
allocate(ftemp1(ldmx))
|
|
allocate(ftemp2(ldmx))
|
|
iat = 0
|
|
write(6,*) 'nsp',nsp
|
|
do is = 1,nsp
|
|
do ia = 1, na(is)
|
|
nsuma = 0.d0
|
|
iat = iat + 1
|
|
! if (iat.eq.1) then
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
do isp = 1, nspin
|
|
do m1 = 1, 2 * Hubbard_l(is) + 1
|
|
nsuma = nsuma + ns (iat, isp, m1, m1)
|
|
end do
|
|
end do
|
|
if (nspin.eq.1) nsuma = 2.d0 * nsuma
|
|
write(6,'(a,x,i2,2x,a,f11.7)') 'atom', iat, &
|
|
& ' Tr[ns(na)]= ',nsuma
|
|
nsum = nsum + nsuma
|
|
!
|
|
do isp = 1, nspin
|
|
|
|
k = 0
|
|
do m1 = 1, 2 * Hubbard_l(is) + 1
|
|
do m2 = m1, 2 * Hubbard_l(is) + 1
|
|
k = k + 1
|
|
f1 ( k ) = ns (iat, isp, m2, m1)
|
|
enddo
|
|
enddo
|
|
|
|
CALL dspev_drv( 'V', 'L', 2 * Hubbard_l(is) + 1, f1, lambda, vet, ldmx )
|
|
|
|
write(6,'(a,x,i2,2x,a,x,i2)') 'atom', iat, 'spin', isp
|
|
write(6,'(a,7f10.7)') 'eigenvalues: ',(lambda(m1),m1=1,&
|
|
& 2 * Hubbard_l(is) + 1)
|
|
write(6,*) 'eigenvectors'
|
|
do m2 = 1, 2*Hubbard_l(is)+1
|
|
write(6,'(i2,2x,7(f10.7,x))') m2,(real(vet(m1,m2)),&
|
|
& m1=1,2 * Hubbard_l(is) + 1)
|
|
end do
|
|
write(6,*) 'occupations'
|
|
do m1 = 1, 2*Hubbard_l(is)+1
|
|
write (6,'(7(f6.3,x))') (ns(iat,isp,m1,m2),m2=1, &
|
|
& 2*Hubbard_l(is)+1)
|
|
end do
|
|
end do
|
|
end if
|
|
! end if
|
|
end do
|
|
end do
|
|
deallocate ( ftemp1, ftemp2)
|
|
return
|
|
end subroutine write_ns
|
|
!-----------------------------------------------------------------------
|
|
subroutine genatwfc(n_atomic_wfc,atwfc)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Compute atomic wavefunctions in G-space, in the same order as used in new_ns
|
|
!
|
|
use parameters, only: mmaxx => ndmx
|
|
use ions_base, only: na, nsp
|
|
use gvecw, only: ngw
|
|
use reciprocal_vectors, only: g, gx, ng0 => gstart
|
|
use cell_base, only: omega, tpiba !@@@@@
|
|
use constants, only: fpi
|
|
USE atom, ONLY: nchi, lchi, chi, r, rab, mesh
|
|
USE kinds, ONLY: DP
|
|
!
|
|
implicit none
|
|
integer, intent(in) :: n_atomic_wfc
|
|
complex(DP), intent(out):: atwfc(ngw,n_atomic_wfc)
|
|
!
|
|
integer natwfc, is, ia, ir, nb, l, m, lm, i, lmax_wfc, ig
|
|
real(DP), allocatable:: ylm(:,:), q(:), jl(:), vchi(:), &
|
|
& chiq(:), gxn(:,:)
|
|
!
|
|
!
|
|
allocate(q(ngw))
|
|
allocate(jl(mmaxx))
|
|
allocate(vchi(mmaxx))
|
|
allocate(gxn(3,ngw))
|
|
allocate(chiq(ngw))
|
|
!
|
|
do ig=1,ngw
|
|
q(ig) = sqrt(g(ig))*tpiba
|
|
end do
|
|
if (ng0.eq.2) gxn(1,:)=0.0
|
|
do ig=ng0,ngw
|
|
gxn(:,ig) = gx(:,ig)/sqrt(g(ig)) !ik<=>ig
|
|
end do
|
|
!
|
|
natwfc=0
|
|
!@@@@@
|
|
!
|
|
! calculate max angular momentum required in wavefunctions
|
|
!
|
|
lmax_wfc=-1
|
|
DO is = 1,nsp
|
|
DO nb = 1, nchi(is)
|
|
lmax_wfc = MAX (lmax_wfc, lchi (nb, is) )
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
ALLOCATE(ylm(ngw,(lmax_wfc+1)**2))
|
|
!
|
|
CALL ylmr2 ((lmax_wfc+1)**2, ngw, gx, g, ylm)
|
|
!@@@@@
|
|
|
|
do is = 1, nsp
|
|
do ia=1,na(is)
|
|
!
|
|
! radial fourier transform of the chi functions
|
|
! NOTA BENE: chi is r times the radial part of the atomic wavefunction
|
|
! bess requires l+1, not l, on input
|
|
!
|
|
do nb = 1,nchi(is)
|
|
l = lchi(nb,is)
|
|
do i=1,ngw
|
|
! call bess(q(i),l+1,mesh(is),r(1,is),jl)
|
|
call sph_bes (mesh(is), r(1,is), q(i), l, jl)
|
|
do ir=1,mesh(is)
|
|
vchi(ir) = chi(ir,nb,is)*r(ir,is)*jl(ir)
|
|
enddo
|
|
call simpson_cp90(mesh(is),vchi,rab(1,is),chiq(i))
|
|
enddo
|
|
!
|
|
! multiply by angular part and structure factor
|
|
! NOTA BENE: the factor i^l MUST be present!!!
|
|
!
|
|
do m = 1,2*l+1
|
|
lm = l**2 + m
|
|
! call ylmr2b(lm,ngw,ngw,gxn,ylm)
|
|
natwfc = natwfc + 1
|
|
atwfc(:,natwfc) = (0.d0,1.d0)**l * ylm(:,lm)*chiq(:)
|
|
enddo
|
|
enddo
|
|
end do
|
|
end do
|
|
!
|
|
do i = 1,natwfc
|
|
call DSCAL(2*ngw,fpi/sqrt(omega),atwfc(1,i),1)
|
|
end do
|
|
!
|
|
if (natwfc.ne.n_atomic_wfc) &
|
|
& call errore('atomic_wfc','unexpected error',natwfc)
|
|
!
|
|
deallocate(chiq)
|
|
deallocate(gxn)
|
|
deallocate(vchi)
|
|
deallocate(jl)
|
|
deallocate(q)
|
|
deallocate(ylm)
|
|
!
|
|
return
|
|
end subroutine genatwfc
|
|
!
|
|
!-------------------------------------------------------------------------
|
|
subroutine dndtau(alpha_a,alpha_s,becwfc,spsi,bp,dbp,wdb, &
|
|
& offset,c,wfc, &
|
|
& eigr,betae, &
|
|
& proj,ipol,dns)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! This routine computes the derivative of the ns with respect to the ionic
|
|
! displacement tau(alpha,ipol) used to obtain the Hubbard contribution to the
|
|
! atomic forces.
|
|
!
|
|
use ions_base, only: na, nat, nsp
|
|
use gvecw, only: ngw
|
|
use electrons_base, only: nspin, n => nbsp, nx => nbspx, ispin, f
|
|
USE uspp, ONLY: nhsa=>nkb
|
|
USE ldaU, ONLY: Hubbard_U, Hubbard_l
|
|
USE ldaU, ONLY: n_atomic_wfc, ns
|
|
USE kinds, ONLY: DP
|
|
!
|
|
implicit none
|
|
integer, parameter :: ldmx = 7
|
|
integer ibnd,is,i,ia,counter, m1,m2, l, iat, alpha, ldim
|
|
! input
|
|
integer, intent(in) :: offset(nsp,nat)
|
|
integer, intent(in) :: alpha_a,alpha_s,ipol
|
|
real(DP), intent(in) :: wfc(ngw,n_atomic_wfc), c(2,ngw,nx), &
|
|
& eigr(2,ngw,nat),betae(2,ngw,nhsa), &
|
|
& becwfc(nhsa,n_atomic_wfc), &
|
|
& bp(nhsa,n), dbp(nhsa,n,3), wdb(nhsa,n_atomic_wfc,3)
|
|
real(DP), intent(in) :: proj(n,n_atomic_wfc)
|
|
complex (DP), intent(in) :: spsi(ngw,n)
|
|
! output
|
|
real (DP), intent(out) :: dns(nat,nspin,ldmx,ldmx)
|
|
!
|
|
! dns !derivative of ns(:,:,:,:) w.r.t. tau
|
|
!
|
|
real (DP), allocatable :: dproj(:,:)
|
|
!
|
|
! dproj(n,n_atomic_wfc) ! derivative of proj(:,:) w.r.t. tau
|
|
!
|
|
allocate (dproj(n,n_atomic_wfc) )
|
|
!
|
|
dns(:,:,:,:) = 0.d0
|
|
!
|
|
call dprojdtau(c,wfc,becwfc,spsi,bp,dbp,wdb,eigr,alpha_a, &
|
|
& alpha_s,ipol,offset(alpha_s,alpha_a),dproj)
|
|
!
|
|
! compute the derivative of occupation numbers (the quantities dn(m1,m2))
|
|
! of the atomic orbitals. They are real quantities as well as n(m1,m2)
|
|
!
|
|
iat=0
|
|
do is=1,nsp
|
|
do ia = 1,na(is)
|
|
iat=iat+1
|
|
if (Hubbard_U(is).ne.0.d0) then
|
|
ldim = 2*Hubbard_l(is) + 1
|
|
do m1 = 1, ldim
|
|
do m2 = m1, ldim
|
|
do ibnd = 1,n
|
|
dns(iat,ispin(ibnd),m1,m2) = &
|
|
& dns(iat,ispin(ibnd),m1,m2) + &
|
|
& f(ibnd)*REAL( proj(ibnd,offset(is,ia)+m1) * &
|
|
& (dproj(ibnd,offset(is,ia)+m2)) + &
|
|
& dproj(ibnd,offset(is,ia)+m1) * &
|
|
& (proj(ibnd,offset(is,ia)+m2)) )
|
|
end do
|
|
dns(iat,:,m2,m1) = dns(iat,:,m1,m2)
|
|
end do
|
|
end do
|
|
end if
|
|
end do
|
|
end do
|
|
!
|
|
deallocate (dproj)
|
|
return
|
|
end subroutine dndtau
|
|
!
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
subroutine dprojdtau(c,wfc,becwfc,spsi,bp,dbp,wdb,eigr,alpha_a, &
|
|
& alpha_s,ipol,offset,dproj)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! This routine computes the first derivative of the projection
|
|
! <\fi^{at}_{I,m1}|S|\psi_{k,v,s}> with respect to the atomic displacement
|
|
! u(alpha,ipol) (we remember that ns_{I,s,m1,m2} = \sum_{k,v}
|
|
! f_{kv} <\fi^{at}_{I,m1}|S|\psi_{k,v,s}><\psi_{k,v,s}|S|\fi^{at}_{I,m2}>)
|
|
!
|
|
use ions_base, only: na, nat
|
|
use gvecw, only: ngw
|
|
use reciprocal_vectors, only: g, gx, ng0 => gstart
|
|
use electrons_base, only: n => nbsp, nx => nbspx
|
|
! use gvec
|
|
! use constants
|
|
USE uspp, ONLY: nhsa=>nkb, qq
|
|
use cvan, ONLY: ish
|
|
USE ldaU, ONLY: Hubbard_U, Hubbard_l
|
|
USE ldaU, ONLY: n_atomic_wfc
|
|
use cell_base, ONLY: tpiba
|
|
USE uspp_param, only: nh !@@@@
|
|
use mp_global, only: intra_image_comm
|
|
use mp, only: mp_sum
|
|
USE kinds, ONLY: DP
|
|
!
|
|
implicit none
|
|
integer, parameter :: ldmx = 7
|
|
integer alpha_a, alpha_s,ipol, offset
|
|
! input: the displaced atom
|
|
! input: the component of displacement
|
|
! input: the offset of the wfcs of the atom "alpha_a,alpha_s"
|
|
complex (DP), intent(in) :: spsi(ngw,n), &
|
|
& c(ngw,nx), eigr(ngw,nat)
|
|
! input: the atomic wfc
|
|
! input: S|evc>
|
|
real(DP), intent(in) ::becwfc(nhsa,n_atomic_wfc), &
|
|
& wfc(2,ngw,n_atomic_wfc), &
|
|
& bp(nhsa,n), dbp(nhsa,n,3), wdb(nhsa,n_atomic_wfc,3)
|
|
real(DP), intent(out) :: dproj(n,n_atomic_wfc)
|
|
! output: the derivative of the projection
|
|
!
|
|
integer i,ig,m1,ibnd,iwf,ia,is,iv,jv,ldim,alpha,l,m,k,inl
|
|
!
|
|
real (DP) a1, a2
|
|
real(kind=8), allocatable :: gk(:)
|
|
!
|
|
complex (DP), allocatable :: dwfc(:,:)
|
|
real (DP), allocatable :: betapsi(:,:), &
|
|
& dbetapsi(:,:), &
|
|
& wfcbeta(:,:),wfcdbeta(:,:),temp(:)
|
|
! dwfc(ngw,ldmx), ! the derivative of the atomic d wfc
|
|
! betapsi(nh,n), ! <beta|evc>
|
|
! dbetapsi(nh,n), ! <dbeta|evc>
|
|
! wfcbeta(n_atomic_wfc,nh), ! <wfc|beta>
|
|
! wfcdbeta(n_atomic_wfc,nh), ! <wfc|dbeta>
|
|
ldim = 2 * Hubbard_l(alpha_s) + 1
|
|
allocate ( dwfc(ngw,ldmx),betapsi(nh(alpha_s),n))
|
|
allocate ( dbetapsi(nh(alpha_s),n), &
|
|
& wfcbeta(n_atomic_wfc,nh(alpha_s)))
|
|
allocate (wfcdbeta(n_atomic_wfc,nh(alpha_s)) )
|
|
dproj(:,:)=0.d0
|
|
!
|
|
! At first the derivative of the atomic wfc is computed
|
|
!
|
|
!
|
|
allocate(gk(ngw))
|
|
allocate(temp(ngw))
|
|
!
|
|
if (Hubbard_U(alpha_s).ne.0.d0) then
|
|
!
|
|
do ig=1,ngw
|
|
gk(ig)=gx(ipol,ig)*tpiba
|
|
!
|
|
do m1=1,ldim
|
|
dwfc(ig,m1) = cmplx (gk(ig)*wfc(2,ig,offset+m1), &
|
|
& -1*gk(ig)*wfc(1,ig,offset+m1) )
|
|
end do
|
|
end do
|
|
!
|
|
do ibnd=1,n
|
|
do m1=1,ldim
|
|
temp(:)=real(conjg(dwfc(:,m1))*spsi(:,ibnd))
|
|
dproj(ibnd,offset+m1)=2.d0*SUM(temp)
|
|
if (ng0.eq.2) dproj(ibnd,offset+m1)=dproj(ibnd,offset+m1)-temp(1)
|
|
end do
|
|
end do
|
|
call mp_sum( dproj, intra_image_comm )
|
|
end if
|
|
do iv=1,nh(alpha_s)
|
|
inl=ish(alpha_s)+(iv-1)*na(alpha_s)+alpha_a
|
|
do i=1,n
|
|
betapsi(iv,i)=bp(inl,i)
|
|
dbetapsi(iv,i)=dbp(inl,i,ipol)
|
|
end do
|
|
do m=1,n_atomic_wfc
|
|
! do m1=1,2**Hubbard_l(is) + 1
|
|
wfcbeta(m,iv)=becwfc(inl,m)
|
|
wfcdbeta(m,iv)=wdb(inl,m,ipol)
|
|
end do
|
|
end do
|
|
do ibnd=1,n
|
|
do iv=1,nh(alpha_s)
|
|
do jv=1,nh(alpha_s)
|
|
do m=1,n_atomic_wfc
|
|
! do m1=1,2**Hubbard_l(is) + 1
|
|
dproj(ibnd,m) = &
|
|
& dproj(ibnd,m) + qq(iv,jv,alpha_s) * &
|
|
& ( wfcdbeta(m,iv)*betapsi(jv,ibnd) + &
|
|
& wfcbeta(m,iv)*dbetapsi(jv,ibnd) )
|
|
end do
|
|
end do
|
|
end do
|
|
end do
|
|
deallocate(temp, gk)
|
|
deallocate (betapsi)
|
|
deallocate (dwfc)
|
|
deallocate (dbetapsi)
|
|
deallocate (wfcbeta)
|
|
deallocate (wfcdbeta)
|
|
return
|
|
end subroutine dprojdtau
|
|
!
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
subroutine stepfn(A,sigma,x_value,g_value,step_value)
|
|
!-----------------------------------------------------------------------
|
|
! This subroutine calculates the value of the gaussian and step
|
|
! functions with a given x_value. A and sigma are given in the
|
|
! input file. ... to be used in occupation_constraint...
|
|
!
|
|
implicit none
|
|
real(kind=8) A, sigma, x_value, g_value, step_value
|
|
real(kind=8) x, pi
|
|
integer i
|
|
pi=3.141592654
|
|
step_value=0.0
|
|
g_value=0.0
|
|
!
|
|
do i=1,100000
|
|
x=x_value + (i-100000)/100000.0*(x_value + 5.d0*sigma)
|
|
!
|
|
! Integrate from 5 sigma before the x_value
|
|
!
|
|
g_value=A*dexp(-x*x/(2*sigma*sigma))/(sigma*dsqrt(2*pi))
|
|
! write(6,*) 'step', step_value,'g',g_value
|
|
! if (g_value.le.0.0) g_value=0.0
|
|
if ((x_value+5*sigma).ge.0.0) then
|
|
step_value=step_value+g_value/100000.0*(x_value+5.d0*sigma)
|
|
end if
|
|
end do
|
|
return
|
|
end subroutine stepfn
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE projwfc_hub( c, nx, eigr, betae, n, n_atomic_wfc, &
|
|
& wfc, becwfc, swfc, proj )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Projection on atomic wavefunctions
|
|
! Atomic wavefunctions are not orthogonized
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE constants, ONLY: autoev
|
|
USE io_global, ONLY: stdout
|
|
USE mp_global, ONLY: intra_image_comm
|
|
USE mp, ONLY: mp_sum
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart
|
|
USE ions_base, ONLY: nsp, na, nat
|
|
USE uspp, ONLY: nhsa => nkb
|
|
USE atom, ONLY: nchi, lchi
|
|
!
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(IN) :: nx, n
|
|
COMPLEX(DP), INTENT(IN) :: c( ngw, nx ), eigr(ngw,nat), betae(ngw,nhsa)
|
|
!
|
|
COMPLEX(DP), INTENT(OUT):: wfc(ngw,n_atomic_wfc), &
|
|
& swfc( ngw, n_atomic_wfc )
|
|
real(DP), intent(out):: becwfc(nhsa,n_atomic_wfc) !DEBUG
|
|
REAL(DP), ALLOCATABLE :: overlap(:,:), e(:), z(:,:)
|
|
REAL(DP), ALLOCATABLE :: temp(:)
|
|
REAL(DP) :: somma, proj(n,n_atomic_wfc)
|
|
INTEGER :: n_atomic_wfc
|
|
INTEGER :: is, ia, nb, l, m, k, i
|
|
!
|
|
! calculate number of atomic states
|
|
!
|
|
!
|
|
IF ( n_atomic_wfc .EQ. 0 ) RETURN
|
|
!
|
|
!
|
|
! calculate wfc = atomic states
|
|
!
|
|
CALL atomic_wfc_northo( eigr, n_atomic_wfc, wfc )
|
|
!
|
|
! calculate bec = <beta|wfc>
|
|
!
|
|
CALL nlsm1( n_atomic_wfc, 1, nsp, eigr, wfc, becwfc )
|
|
!
|
|
! calculate swfc = S|wfc>
|
|
!
|
|
CALL s_wfc( n_atomic_wfc, becwfc, betae, wfc, swfc )
|
|
!
|
|
! calculate proj = <c|S|wfc>
|
|
!
|
|
ALLOCATE(temp(ngw))
|
|
DO m=1,n
|
|
DO l=1,n_atomic_wfc
|
|
temp(:)=DBLE(CONJG(c(:,m))*swfc(:,l)) !@@@@
|
|
proj(m,l)=2.d0*SUM(temp)
|
|
IF (gstart == 2) proj(m,l)=proj(m,l)-temp(1)
|
|
END DO
|
|
END DO
|
|
DEALLOCATE(temp)
|
|
CALL mp_sum( proj, intra_image_comm )
|
|
!
|
|
RETURN
|
|
END SUBROUTINE projwfc_hub
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE atomic_wfc_northo( eigr, n_atomic_wfc, wfc )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! Compute atomic wavefunctions in G-space
|
|
! Atomic wavefunctions not orthogonalized
|
|
!
|
|
USE kinds, ONLY: DP
|
|
USE gvecw, ONLY: ngw
|
|
USE reciprocal_vectors, ONLY: gstart, g, gx
|
|
USE ions_base, ONLY: nsp, na, nat
|
|
USE cell_base, ONLY: tpiba, omega !@@@@
|
|
USE atom, ONLY: nchi, lchi, mesh, r, chi, rab
|
|
!@@@@@
|
|
USE constants, ONLY: fpi
|
|
!@@@@@
|
|
!
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(in) :: n_atomic_wfc
|
|
COMPLEX(DP), INTENT(in) :: eigr( ngw, nat )
|
|
COMPLEX(DP), INTENT(out):: wfc( ngw, n_atomic_wfc )
|
|
!
|
|
INTEGER :: natwfc, ndm, is, ia, ir, nb, l, m, lm, i, lmax_wfc, isa
|
|
REAL(DP), ALLOCATABLE :: ylm(:,:), q(:), jl(:), vchi(:), chiq(:)
|
|
!
|
|
! calculate max angular momentum required in wavefunctions
|
|
!
|
|
lmax_wfc=-1
|
|
DO is = 1,nsp
|
|
DO nb = 1, nchi(is)
|
|
lmax_wfc = MAX (lmax_wfc, lchi (nb, is) )
|
|
ENDDO
|
|
ENDDO
|
|
!
|
|
ALLOCATE(ylm(ngw,(lmax_wfc+1)**2))
|
|
!
|
|
CALL ylmr2 ((lmax_wfc+1)**2, ngw, gx, g, ylm)
|
|
ndm = MAXVAL(mesh(1:nsp))
|
|
!
|
|
ALLOCATE(jl(ndm), vchi(ndm))
|
|
ALLOCATE(q(ngw), chiq(ngw))
|
|
!
|
|
DO i=1,ngw
|
|
q(i) = SQRT(g(i))*tpiba
|
|
END DO
|
|
!
|
|
natwfc=0
|
|
isa = 0
|
|
DO is=1,nsp
|
|
!
|
|
! radial fourier transform of the chi functions
|
|
! NOTA BENE: chi is r times the radial part of the atomic wavefunction
|
|
!
|
|
DO nb = 1,nchi(is)
|
|
l = lchi(nb,is)
|
|
DO i=1,ngw
|
|
CALL sph_bes (mesh(is), r(1,is), q(i), l, jl)
|
|
DO ir=1,mesh(is)
|
|
vchi(ir) = chi(ir,nb,is)*r(ir,is)*jl(ir)
|
|
ENDDO
|
|
CALL simpson_cp90(mesh(is),vchi,rab(1,is),chiq(i))
|
|
ENDDO
|
|
!
|
|
! multiply by angular part and structure factor
|
|
! NOTA BENE: the factor i^l MUST be present!!!
|
|
!
|
|
DO m = 1,2*l+1
|
|
lm = l**2 + m
|
|
DO ia = 1 + isa, na(is) + isa
|
|
natwfc = natwfc + 1
|
|
wfc(:,natwfc) = (0.d0,1.d0)**l * eigr(:,ia)* ylm(:,lm)*chiq(:)
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
isa = isa + na(is)
|
|
ENDDO
|
|
!
|
|
IF (natwfc.NE.n_atomic_wfc) &
|
|
& CALL errore('atomic_wfc','unexpected error',natwfc)
|
|
!
|
|
!@@@@@
|
|
do i = 1,n_atomic_wfc
|
|
call DSCAL(2*ngw,fpi/sqrt(omega),wfc(1,i),1)
|
|
end do
|
|
!@@@@@
|
|
DEALLOCATE(q, chiq, vchi, jl, ylm)
|
|
!
|
|
RETURN
|
|
END SUBROUTINE atomic_wfc_northo
|