mirror of https://gitlab.com/QEF/q-e.git
961 lines
30 KiB
Fortran
961 lines
30 KiB
Fortran
!
|
|
! Copyright (C) 2001-2007 Quantum-ESPRESSO group
|
|
! 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"
|
|
!
|
|
!----------------------------------------------------------------------------
|
|
MODULE realus
|
|
!----------------------------------------------------------------------------
|
|
!
|
|
USE kinds, ONLY : DP
|
|
!
|
|
! ... module originally written by Antonio Suriano and Stefano de Gironcoli
|
|
! ... modified by Carlo Sbraccia
|
|
!
|
|
INTEGER, ALLOCATABLE :: box(:,:), maxbox(:)
|
|
REAL(DP), ALLOCATABLE :: qsave(:)
|
|
REAL(DP), ALLOCATABLE :: boxrad(:)
|
|
REAL(DP), ALLOCATABLE :: boxdist(:,:), xyz(:,:,:)
|
|
REAL(DP), ALLOCATABLE :: spher(:,:,:)
|
|
!
|
|
CONTAINS
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE deallocatenewdreal()
|
|
!------------------------------------------------------------------------
|
|
!
|
|
IF ( ALLOCATED( box ) ) DEALLOCATE( box )
|
|
IF ( ALLOCATED( maxbox ) ) DEALLOCATE( maxbox )
|
|
IF ( ALLOCATED( qsave ) ) DEALLOCATE( qsave )
|
|
IF ( ALLOCATED( boxrad ) ) DEALLOCATE( boxrad )
|
|
!
|
|
END SUBROUTINE deallocatenewdreal
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE qpointlist()
|
|
!------------------------------------------------------------------------
|
|
!
|
|
! ... This subroutine is the driver routine of the box system in this
|
|
! ... implementation of US in real space.
|
|
! ... All the variables common in the module are computed and stored for
|
|
! ... reusing.
|
|
! ... This routine has to be called every time the atoms are moved and of
|
|
! ... course at the beginning.
|
|
! ... A set of spherical boxes are computed for each atom.
|
|
! ... In boxradius there are the radii of the boxes.
|
|
! ... In maxbox the upper limit of leading index, namely the number of
|
|
! ... points of the fine mesh contained in each box.
|
|
! ... In xyz there are the coordinates of the points with origin in the
|
|
! ... centre of atom.
|
|
! ... In boxdist the distance from the centre.
|
|
! ... In spher the spherical harmonics computed for each box
|
|
! ... In qsave the q value interpolated in these boxes.
|
|
!
|
|
! ... Most of time is spent here; the calling routines are faster.
|
|
!
|
|
USE constants, ONLY : pi, fpi, eps8, eps16
|
|
USE ions_base, ONLY : nat, nsp, ityp, tau
|
|
USE cell_base, ONLY : at, bg, omega, alat
|
|
USE gvect, ONLY : nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx
|
|
USE uspp, ONLY : okvan, indv, nhtol, nhtolm, ap, nhtoj, lpx, lpl
|
|
USE uspp_param, ONLY : upf, lmaxq, nh, nhm
|
|
USE atom, ONLY : rgrid
|
|
USE fft_base, ONLY : dfftp
|
|
USE mp_global, ONLY : me_pool
|
|
USE splinelib, ONLY : spline, splint
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: qsdim, ia, mbia, iqs, iqsia
|
|
INTEGER :: indm, idimension, &
|
|
ih, jh, ijh, lllnbnt, lllmbnt
|
|
INTEGER :: roughestimate, goodestimate, lamx2, l, nt
|
|
INTEGER, ALLOCATABLE :: buffpoints(:,:)
|
|
REAL(DP), ALLOCATABLE :: buffdist(:,:)
|
|
REAL(DP) :: distsq, qtot_int, first, second
|
|
INTEGER :: idx0, idx, ir
|
|
INTEGER :: i, j, k, ipol, lm, nb, mb, ijv, ilast
|
|
REAL(DP) :: posi(3)
|
|
REAL(DP), ALLOCATABLE :: rl(:,:), rl2(:)
|
|
REAL(DP), ALLOCATABLE :: tempspher(:,:), qtot(:,:,:), &
|
|
xsp(:), ysp(:), wsp(:)
|
|
REAL(DP) :: mbr, mbx, mby, mbz, dmbx, dmby, dmbz
|
|
REAL(DP) :: inv_nr1, inv_nr2, inv_nr3, tau_ia(3), boxradsq_ia
|
|
!
|
|
!
|
|
IF ( .NOT. okvan ) RETURN
|
|
!
|
|
CALL start_clock( 'realus' )
|
|
!
|
|
! ... qsave is deallocated here to free the memory for the buffers
|
|
!
|
|
IF ( ALLOCATED( qsave ) ) DEALLOCATE( qsave )
|
|
!
|
|
IF ( .NOT. ALLOCATED( boxrad ) ) THEN
|
|
!
|
|
! ... here we calculate the radius of each spherical box ( one
|
|
! ... for each non-local projector )
|
|
!
|
|
ALLOCATE( boxrad( nsp ) )
|
|
!
|
|
boxrad(:) = 0.D0
|
|
!
|
|
DO nt = 1, nsp
|
|
DO ijv = 1, upf(nt)%nbeta*(upf(nt)%nbeta+1)/2
|
|
DO indm = upf(nt)%kkbeta, 1, -1
|
|
!
|
|
IF ( ABS( upf(nt)%qfunc(indm,ijv) ) > eps16 ) THEN
|
|
!
|
|
boxrad(nt) = MAX( rgrid(nt)%r(indm), boxrad(nt) )
|
|
!
|
|
CYCLE
|
|
!
|
|
END IF
|
|
!
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
boxrad(:) = boxrad(:) / alat
|
|
!
|
|
END IF
|
|
!
|
|
! ... a rough estimate for the number of grid-points per box
|
|
! ... is provided here
|
|
!
|
|
mbr = MAXVAL( boxrad(:) )
|
|
!
|
|
mbx = mbr*SQRT( bg(1,1)**2 + bg(1,2)**2 + bg(1,3)**2 )
|
|
mby = mbr*SQRT( bg(2,1)**2 + bg(2,2)**2 + bg(2,3)**2 )
|
|
mbz = mbr*SQRT( bg(3,1)**2 + bg(3,2)**2 + bg(3,3)**2 )
|
|
!
|
|
dmbx = 2*ANINT( mbx*nrx1 ) + 2
|
|
dmby = 2*ANINT( mby*nrx2 ) + 2
|
|
dmbz = 2*ANINT( mbz*nrx3 ) + 2
|
|
!
|
|
roughestimate = ANINT( DBLE( dmbx*dmby*dmbz ) * pi / 6.D0 )
|
|
!
|
|
CALL start_clock( 'realus:boxes' )
|
|
!
|
|
ALLOCATE( buffpoints( roughestimate, nat ) )
|
|
ALLOCATE( buffdist( roughestimate, nat ) )
|
|
!
|
|
ALLOCATE( xyz( 3, roughestimate, nat ) )
|
|
!
|
|
buffpoints(:,:) = 0
|
|
buffdist(:,:) = 0.D0
|
|
!
|
|
IF ( .NOT.ALLOCATED( maxbox ) ) ALLOCATE( maxbox( nat ) )
|
|
!
|
|
maxbox(:) = 0
|
|
!
|
|
! ... now we find the points
|
|
!
|
|
#if defined (__PARA)
|
|
idx0 = nrx1*nrx2 * SUM ( dfftp%npp(1:me_pool) )
|
|
#else
|
|
idx0 = 0
|
|
#endif
|
|
!
|
|
inv_nr1 = 1.D0 / DBLE( nr1 )
|
|
inv_nr2 = 1.D0 / DBLE( nr2 )
|
|
inv_nr3 = 1.D0 / DBLE( nr3 )
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
IF ( .NOT. upf(nt)%tvanp ) CYCLE
|
|
!
|
|
boxradsq_ia = boxrad(nt)**2
|
|
!
|
|
tau_ia(1) = tau(1,ia)
|
|
tau_ia(2) = tau(2,ia)
|
|
tau_ia(3) = tau(3,ia)
|
|
!
|
|
DO ir = 1, nrxx
|
|
!
|
|
! ... three dimensional indices (i,j,k)
|
|
!
|
|
idx = idx0 + ir - 1
|
|
k = idx / (nrx1*nrx2)
|
|
idx = idx - (nrx1*nrx2)*k
|
|
j = idx / nrx1
|
|
idx = idx - nrx1*j
|
|
i = idx
|
|
!
|
|
! ... do not include points outside the physical range!
|
|
!
|
|
IF ( i >= nr1 .or. j >= nr2 .or. k >= nr3 ) CYCLE
|
|
!
|
|
DO ipol = 1, 3
|
|
posi(ipol) = DBLE( i )*inv_nr1*at(ipol,1) + &
|
|
DBLE( j )*inv_nr2*at(ipol,2) + &
|
|
DBLE( k )*inv_nr3*at(ipol,3)
|
|
END DO
|
|
!
|
|
posi(:) = posi(:) - tau_ia(:)
|
|
!
|
|
! ... minimum image convenction
|
|
!
|
|
CALL cryst_to_cart( 1, posi, bg, -1 )
|
|
!
|
|
posi(:) = posi(:) - ANINT( posi(:) )
|
|
!
|
|
CALL cryst_to_cart( 1, posi, at, 1 )
|
|
!
|
|
distsq = posi(1)**2 + posi(2)**2 + posi(3)**2
|
|
!
|
|
IF ( distsq < boxradsq_ia ) THEN
|
|
!
|
|
mbia = maxbox(ia) + 1
|
|
!
|
|
maxbox(ia) = mbia
|
|
buffpoints(mbia,ia) = ir
|
|
buffdist(mbia,ia) = SQRT( distsq )*alat
|
|
xyz(:,mbia,ia) = posi(:)*alat
|
|
!
|
|
END IF
|
|
END DO
|
|
END DO
|
|
!
|
|
goodestimate = MAXVAL( maxbox )
|
|
!
|
|
IF ( goodestimate > roughestimate ) &
|
|
CALL errore( 'qpointlist', 'rough-estimate is too rough', 2 )
|
|
!
|
|
! ... now store them in a more convenient place
|
|
!
|
|
IF ( ALLOCATED( box ) ) DEALLOCATE( box )
|
|
IF ( ALLOCATED( boxdist ) ) DEALLOCATE( boxdist )
|
|
!
|
|
ALLOCATE( box( goodestimate, nat ) )
|
|
ALLOCATE( boxdist( goodestimate, nat ) )
|
|
!
|
|
box(:,:) = buffpoints(1:goodestimate,:)
|
|
boxdist(:,:) = buffdist(1:goodestimate,:)
|
|
!
|
|
DEALLOCATE( buffpoints )
|
|
DEALLOCATE( buffdist )
|
|
!
|
|
CALL stop_clock( 'realus:boxes' )
|
|
CALL start_clock( 'realus:spher' )
|
|
!
|
|
! ... now it computes the spherical harmonics
|
|
!
|
|
lamx2 = lmaxq*lmaxq
|
|
!
|
|
IF ( ALLOCATED( spher ) ) DEALLOCATE( spher )
|
|
!
|
|
ALLOCATE( spher( goodestimate, lamx2, nat ) )
|
|
!
|
|
spher(:,:,:) = 0.D0
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
IF ( .NOT. upf(nt)%tvanp ) CYCLE
|
|
!
|
|
idimension = maxbox(ia)
|
|
!
|
|
ALLOCATE( rl( 3, idimension ), rl2( idimension ) )
|
|
!
|
|
DO ir = 1, idimension
|
|
!
|
|
rl(:,ir) = xyz(:,ir,ia)
|
|
!
|
|
rl2(ir) = rl(1,ir)**2 + rl(2,ir)**2 + rl(3,ir)**2
|
|
!
|
|
END DO
|
|
!
|
|
ALLOCATE( tempspher( idimension, lamx2 ) )
|
|
!
|
|
CALL ylmr2( lamx2, idimension, rl, rl2, tempspher )
|
|
!
|
|
spher(1:idimension,:,ia) = tempspher(:,:)
|
|
!
|
|
DEALLOCATE( rl, rl2, tempspher )
|
|
!
|
|
END DO
|
|
!
|
|
DEALLOCATE( xyz )
|
|
!
|
|
CALL stop_clock( 'realus:spher' )
|
|
CALL start_clock( 'realus:qsave' )
|
|
!
|
|
! ... let's do the main work
|
|
!
|
|
qsdim = 0
|
|
DO ia = 1, nat
|
|
mbia = maxbox(ia)
|
|
IF ( mbia == 0 ) CYCLE
|
|
nt = ityp(ia)
|
|
IF ( .NOT. upf(nt)%tvanp ) CYCLE
|
|
DO ih = 1, nh(nt)
|
|
DO jh = ih, nh(nt)
|
|
qsdim = qsdim + mbia
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! PRINT *, "QSAVE SIZE : ", qsdim
|
|
!
|
|
ALLOCATE( qsave( qsdim ) )
|
|
!
|
|
qsave(:) = 0.D0
|
|
!
|
|
! ... the source is inspired by init_us_1
|
|
!
|
|
! ... we perform two steps: first we compute for each l the qtot
|
|
! ... (radial q), then we interpolate it in our mesh, and then we
|
|
! ... add it to qsave with the correct spherical harmonics
|
|
!
|
|
! ... Q is read from pseudo and it is divided into two parts:
|
|
! ... in the inner radius a polinomial representation is known and so
|
|
! ... strictly speaking we do not use interpolation but just compute
|
|
! ... the correct value
|
|
!
|
|
iqs = 0
|
|
iqsia = 0
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
mbia = maxbox(ia)
|
|
!
|
|
IF ( mbia == 0 ) CYCLE
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
IF ( .NOT. upf(nt)%tvanp ) CYCLE
|
|
!
|
|
ALLOCATE( qtot( upf(nt)%kkbeta, upf(nt)%nbeta, upf(nt)%nbeta ) )
|
|
!
|
|
! ... variables used for spline interpolation
|
|
!
|
|
ALLOCATE( xsp( upf(nt)%kkbeta ), ysp( upf(nt)%kkbeta ), &
|
|
wsp( upf(nt)%kkbeta ) )
|
|
!
|
|
! ... the radii in x
|
|
!
|
|
xsp(:) = rgrid(nt)%r(1:upf(nt)%kkbeta)
|
|
!
|
|
DO l = 0, upf(nt)%nqlc - 1
|
|
!
|
|
! ... first we build for each nb,mb,l the total Q(|r|) function
|
|
! ... note that l is the true (combined) angular momentum
|
|
! ... and that the arrays have dimensions 1..l+1
|
|
!
|
|
DO nb = 1, upf(nt)%nbeta
|
|
DO mb = nb, upf(nt)%nbeta
|
|
ijv = mb * (mb-1) /2 + nb
|
|
!
|
|
lllnbnt = upf(nt)%lll(nb)
|
|
lllmbnt = upf(nt)%lll(mb)
|
|
!
|
|
IF ( .NOT. ( l >= ABS( lllnbnt - lllmbnt ) .AND. &
|
|
l <= lllnbnt + lllmbnt .AND. &
|
|
MOD( l + lllnbnt + lllmbnt, 2 ) == 0 ) ) CYCLE
|
|
!
|
|
DO ir = 1, upf(nt)%kkbeta
|
|
IF ( rgrid(nt)%r(ir) >= upf(nt)%rinner(l+1) ) THEN
|
|
qtot(ir,nb,mb) = upf(nt)%qfunc(ir,ijv) / &
|
|
rgrid(nt)%r(ir)**2
|
|
ELSE
|
|
ilast = ir
|
|
END IF
|
|
END DO
|
|
!
|
|
IF ( upf(nt)%rinner(l+1) > 0.D0 ) &
|
|
CALL setqfcorr( upf(nt)%qfcoef(1:,l+1,nb,mb), &
|
|
qtot(1,nb,mb), rgrid(nt)%r, upf(nt)%nqf, l, ilast )
|
|
!
|
|
! ... we save the values in y
|
|
!
|
|
ysp(:) = qtot(1:upf(nt)%kkbeta,nb,mb)
|
|
!
|
|
! ... compute the first derivative in first point
|
|
!
|
|
CALL setqfcorrptfirst( upf(nt)%qfcoef(1:,l+1,nb,mb), &
|
|
first, rgrid(nt)%r(1), upf(nt)%nqf, l )
|
|
!
|
|
! ... compute the second derivative in second point
|
|
!
|
|
CALL setqfcorrptsecond( upf(nt)%qfcoef(1:,l+1,nb,mb), &
|
|
second, rgrid(nt)%r(1), upf(nt)%nqf, l )
|
|
!
|
|
! ... call spline
|
|
!
|
|
CALL spline( xsp, ysp, first, second, wsp )
|
|
!
|
|
DO ir = 1, maxbox(ia)
|
|
!
|
|
IF ( boxdist(ir,ia) < upf(nt)%rinner(l+1) ) THEN
|
|
!
|
|
! ... if in the inner radius just compute the
|
|
! ... polynomial
|
|
!
|
|
CALL setqfcorrpt( upf(nt)%qfcoef(1:,l+1,nb,mb), &
|
|
qtot_int, boxdist(ir,ia), upf(nt)%nqf, l )
|
|
!
|
|
ELSE
|
|
!
|
|
! ... spline interpolation
|
|
!
|
|
qtot_int = splint( xsp, ysp, wsp, boxdist(ir,ia) )
|
|
!
|
|
END IF
|
|
!
|
|
ijh = 0
|
|
!
|
|
DO ih = 1, nh(nt)
|
|
DO jh = ih, nh(nt)
|
|
!
|
|
iqs = iqsia + ijh*mbia + ir
|
|
ijh = ijh + 1
|
|
!
|
|
IF ( .NOT.( nb == indv(ih,nt) .AND. &
|
|
mb == indv(jh,nt) ) ) CYCLE
|
|
!
|
|
DO lm = l*l+1, (l+1)*(l+1)
|
|
!
|
|
qsave(iqs) = qsave(iqs) + &
|
|
qtot_int*spher(ir,lm,ia)*&
|
|
ap(lm,nhtolm(ih,nt),nhtolm(jh,nt))
|
|
!
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
iqsia = iqs
|
|
!
|
|
DEALLOCATE( qtot )
|
|
DEALLOCATE( xsp )
|
|
DEALLOCATE( ysp )
|
|
DEALLOCATE( wsp )
|
|
!
|
|
END DO
|
|
!
|
|
DEALLOCATE( boxdist )
|
|
DEALLOCATE( spher )
|
|
!
|
|
CALL stop_clock( 'realus:qsave' )
|
|
CALL stop_clock( 'realus' )
|
|
!
|
|
END SUBROUTINE qpointlist
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE newd_r()
|
|
!------------------------------------------------------------------------
|
|
!
|
|
! ... this subroutine is the version of newd in real space
|
|
!
|
|
USE constants, ONLY : pi, fpi
|
|
USE ions_base, ONLY : nat, ityp
|
|
USE cell_base, ONLY : omega
|
|
USE gvect, ONLY : nr1, nr2, nr3, nrxx
|
|
USE lsda_mod, ONLY : nspin
|
|
USE scf, ONLY : v, vltot
|
|
USE uspp, ONLY : okvan, deeq, deeq_nc, dvan, dvan_so
|
|
USE uspp_param, ONLY : upf, nh, nhm
|
|
USE noncollin_module, ONLY : noncolin
|
|
USE spin_orb, ONLY : domag, lspinorb
|
|
USE mp_global, ONLY : intra_pool_comm
|
|
USE mp, ONLY : mp_sum
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(DP), ALLOCATABLE :: aux(:)
|
|
INTEGER :: ia, ih, jh, is, ir, nt, nspin0
|
|
INTEGER :: mbia, nht, nhnt, iqs
|
|
!
|
|
IF ( .NOT. okvan ) THEN
|
|
!
|
|
! ... no ultrasoft potentials: use bare coefficients for projectors
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
nt = ityp(ia)
|
|
nht = nh(nt)
|
|
!
|
|
IF ( lspinorb ) THEN
|
|
!
|
|
deeq_nc(1:nht,1:nht,ia,1:nspin) = dvan_so(1:nht,1:nht,1:nspin,nt)
|
|
!
|
|
ELSE IF ( noncolin ) THEN
|
|
!
|
|
deeq_nc(1:nht,1:nht,ia,1) = dvan(1:nht,1:nht,nt)
|
|
deeq_nc(1:nht,1:nht,ia,2) = ( 0.D0, 0.D0 )
|
|
deeq_nc(1:nht,1:nht,ia,3) = ( 0.D0, 0.D0 )
|
|
deeq_nc(1:nht,1:nht,ia,4) = dvan(1:nht,1:nht,nt)
|
|
!
|
|
ELSE
|
|
!
|
|
DO is = 1, nspin
|
|
!
|
|
deeq(1:nht,1:nht,ia,is) = dvan(1:nht,1:nht,nt)
|
|
!
|
|
END DO
|
|
!
|
|
END IF
|
|
!
|
|
END DO
|
|
!
|
|
! ... early return
|
|
!
|
|
RETURN
|
|
!
|
|
END IF
|
|
!
|
|
CALL start_clock( 'newd' )
|
|
!
|
|
nspin0 = nspin
|
|
!
|
|
IF ( noncolin .AND..NOT. domag ) nspin0 = 1
|
|
!
|
|
deeq(:,:,:,:) = 0.D0
|
|
!
|
|
ALLOCATE( aux( nrxx ) )
|
|
!
|
|
DO is = 1, nspin0
|
|
!
|
|
IF ( nspin0 == 4 .AND. is /= 1 ) THEN
|
|
aux(:) = v%of_r(:,is)
|
|
ELSE
|
|
aux(:) = vltot(:) + v%of_r(:,is)
|
|
END IF
|
|
!
|
|
iqs = 0
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
mbia = maxbox(ia)
|
|
!
|
|
IF ( mbia == 0 ) CYCLE
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
IF ( .NOT. upf(nt)%tvanp ) CYCLE
|
|
!
|
|
nhnt = nh(nt)
|
|
!
|
|
DO ih = 1, nhnt
|
|
DO jh = ih, nhnt
|
|
DO ir = 1, mbia
|
|
iqs = iqs + 1
|
|
deeq(ih,jh,ia,is)= deeq(ih,jh,ia,is) + &
|
|
qsave(iqs)*aux(box(ir,ia))
|
|
END DO
|
|
deeq(jh,ih,ia,is) = deeq(ih,jh,ia,is)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
deeq(:,:,:,:) = deeq(:,:,:,:)*omega/(nr1*nr2*nr3)
|
|
!
|
|
DEALLOCATE( aux )
|
|
!
|
|
CALL mp_sum( deeq(:,:,:,1:nspin0) , intra_pool_comm )
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
IF ( noncolin ) THEN
|
|
!
|
|
IF ( upf(nt)%has_so ) THEN
|
|
CALL newd_so( ia )
|
|
ELSE
|
|
CALL newd_nc( ia )
|
|
END IF
|
|
!
|
|
ELSE
|
|
!
|
|
nhnt = nh(nt)
|
|
!
|
|
DO is = 1, nspin0
|
|
DO ih = 1, nhnt
|
|
DO jh = ih, nhnt
|
|
deeq(ih,jh,ia,is) = deeq(ih,jh,ia,is) + dvan(ih,jh,nt)
|
|
deeq(jh,ih,ia,is) = deeq(ih,jh,ia,is)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
END IF
|
|
ENDDO
|
|
!
|
|
CALL stop_clock( 'newd' )
|
|
!
|
|
RETURN
|
|
!
|
|
CONTAINS
|
|
!
|
|
!--------------------------------------------------------------------
|
|
SUBROUTINE newd_so( ia )
|
|
!--------------------------------------------------------------------
|
|
!
|
|
USE spin_orb, ONLY : fcoef, domag, lspinorb
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: ia
|
|
INTEGER :: ijs, is1, is2, kh, lh
|
|
!
|
|
!
|
|
nt = ityp(ia)
|
|
ijs = 0
|
|
!
|
|
DO is1 = 1, 2
|
|
DO is2 = 1, 2
|
|
!
|
|
ijs = ijs + 1
|
|
!
|
|
IF ( domag ) THEN
|
|
!
|
|
DO ih = 1, nh(nt)
|
|
DO jh = 1, nh(nt)
|
|
!
|
|
deeq_nc(ih,jh,ia,ijs) = dvan_so(ih,jh,ijs,nt)
|
|
!
|
|
DO kh = 1, nh(nt)
|
|
DO lh = 1, nh(nt)
|
|
!
|
|
deeq_nc(ih,jh,ia,ijs) = deeq_nc(ih,jh,ia,ijs) + &
|
|
deeq (kh,lh,ia,1)* &
|
|
(fcoef(ih,kh,is1,1,nt)*fcoef(lh,jh,1,is2,nt) + &
|
|
fcoef(ih,kh,is1,2,nt)*fcoef(lh,jh,2,is2,nt)) + &
|
|
deeq (kh,lh,ia,2)* &
|
|
(fcoef(ih,kh,is1,1,nt)*fcoef(lh,jh,2,is2,nt) + &
|
|
fcoef(ih,kh,is1,2,nt)*fcoef(lh,jh,1,is2,nt)) + &
|
|
(0.D0,-1.D0)*deeq (kh,lh,ia,3)* &
|
|
(fcoef(ih,kh,is1,1,nt)*fcoef(lh,jh,2,is2,nt) - &
|
|
fcoef(ih,kh,is1,2,nt)*fcoef(lh,jh,1,is2,nt)) + &
|
|
deeq (kh,lh,ia,4)* &
|
|
(fcoef(ih,kh,is1,1,nt)*fcoef(lh,jh,1,is2,nt) - &
|
|
fcoef(ih,kh,is1,2,nt)*fcoef(lh,jh,2,is2,nt))
|
|
!
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ELSE
|
|
!
|
|
DO ih = 1, nh(nt)
|
|
DO jh = 1, nh(nt)
|
|
!
|
|
deeq_nc(ih,jh,ia,ijs) = dvan_so(ih,jh,ijs,nt)
|
|
!
|
|
DO kh = 1, nh(nt)
|
|
DO lh = 1, nh(nt)
|
|
!
|
|
deeq_nc(ih,jh,ia,ijs) = deeq_nc(ih,jh,ia,ijs) + &
|
|
deeq (kh,lh,ia,1)* &
|
|
(fcoef(ih,kh,is1,1,nt)*fcoef(lh,jh,1,is2,nt) + &
|
|
fcoef(ih,kh,is1,2,nt)*fcoef(lh,jh,2,is2,nt) )
|
|
!
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
END IF
|
|
!
|
|
END DO
|
|
END DO
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE newd_so
|
|
!
|
|
!--------------------------------------------------------------------
|
|
SUBROUTINE newd_nc( ia )
|
|
!--------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: ia
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
DO ih = 1, nh(nt)
|
|
DO jh = 1, nh(nt)
|
|
!
|
|
IF ( lspinorb ) THEN
|
|
!
|
|
deeq_nc(ih,jh,ia,1) = dvan_so(ih,jh,1,nt) + &
|
|
deeq(ih,jh,ia,1) + deeq(ih,jh,ia,4)
|
|
deeq_nc(ih,jh,ia,4) = dvan_so(ih,jh,4,nt) + &
|
|
deeq(ih,jh,ia,1) - deeq(ih,jh,ia,4)
|
|
!
|
|
ELSE
|
|
!
|
|
deeq_nc(ih,jh,ia,1) = dvan(ih,jh,nt) + &
|
|
deeq(ih,jh,ia,1) + deeq(ih,jh,ia,4)
|
|
deeq_nc(ih,jh,ia,4) = dvan(ih,jh,nt) + &
|
|
deeq(ih,jh,ia,1) - deeq(ih,jh,ia,4)
|
|
!
|
|
END IF
|
|
!
|
|
deeq_nc(ih,jh,ia,2) = deeq(ih,jh,ia,2) - &
|
|
( 0.D0, 1.D0 ) * deeq(ih,jh,ia,3)
|
|
!
|
|
deeq_nc(ih,jh,ia,3) = deeq(ih,jh,ia,2) + &
|
|
( 0.D0, 1.D0 ) * deeq(ih,jh,ia,3)
|
|
!
|
|
END DO
|
|
END DO
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE newd_nc
|
|
!
|
|
END SUBROUTINE newd_r
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE setqfcorr( qfcoef, rho, r, nqf, ltot, mesh )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! ... This routine compute the first part of the Q function up to rinner.
|
|
! ... On output it contains Q
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN):: nqf, ltot, mesh
|
|
! input: the number of coefficients
|
|
! input: the angular momentum
|
|
! input: the number of mesh point
|
|
REAL(DP), INTENT(IN) :: r(mesh), qfcoef(nqf)
|
|
! input: the radial mesh
|
|
! input: the coefficients of Q
|
|
REAL(DP), INTENT(OUT) :: rho(mesh)
|
|
! output: the function to be computed
|
|
!
|
|
INTEGER :: ir, i
|
|
REAL(DP) :: rr
|
|
!
|
|
DO ir = 1, mesh
|
|
!
|
|
rr = r(ir)**2
|
|
!
|
|
rho(ir) = qfcoef(1)
|
|
!
|
|
DO i = 2, nqf
|
|
rho(ir) = rho(ir) + qfcoef(i)*rr**(i-1)
|
|
END DO
|
|
!
|
|
rho(ir) = rho(ir)*r(ir)**ltot
|
|
!
|
|
END DO
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE setqfcorr
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE setqfcorrpt( qfcoef, rho, r, nqf, ltot )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
! ... This routine compute the first part of the Q function at the
|
|
! ... point r. On output it contains Q
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN):: nqf, ltot
|
|
! input: the number of coefficients
|
|
! input: the angular momentum
|
|
REAL(DP), INTENT(IN) :: r, qfcoef(nqf)
|
|
! input: the radial mesh
|
|
! input: the coefficients of Q
|
|
REAL(DP), INTENT(OUT) :: rho
|
|
! output: the function to be computed
|
|
!
|
|
INTEGER :: i
|
|
REAL(DP) :: rr
|
|
!
|
|
rr = r*r
|
|
!
|
|
rho = qfcoef(1)
|
|
!
|
|
DO i = 2, nqf
|
|
rho = rho + qfcoef(i)*rr**(i-1)
|
|
END DO
|
|
!
|
|
rho = rho*r**ltot
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE setqfcorrpt
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE setqfcorrptfirst( qfcoef, rho, r, nqf, ltot )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
! ... On output it contains Q' (probably wrong)
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: nqf, ltot
|
|
! input: the number of coefficients
|
|
! input: the angular momentum
|
|
REAL(DP), INTENT(IN) :: r, qfcoef(nqf)
|
|
! input: the radial mesh
|
|
! input: the coefficients of Q
|
|
REAL(DP), INTENT(OUT) :: rho
|
|
! output: the function to be computed
|
|
!
|
|
INTEGER :: i
|
|
REAL(DP) :: rr
|
|
!
|
|
rr = r*r
|
|
!
|
|
rho = 0.D0
|
|
!
|
|
DO i = MAX( 1, 2-ltot ), nqf
|
|
rho = rho + qfcoef(i)*rr**(i-2+ltot)*(i-1+ltot)
|
|
END DO
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE setqfcorrptfirst
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE setqfcorrptsecond( qfcoef, rho, r, nqf, ltot )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
! ... On output it contains Q''
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: nqf, ltot
|
|
! input: the number of coefficients
|
|
! input: the angular momentum
|
|
REAL(DP), INTENT(IN) :: r, qfcoef(nqf)
|
|
! input: the radial mesh
|
|
! input: the coefficients of Q
|
|
REAL(DP), INTENT(OUT) :: rho
|
|
! output: the function to be computed
|
|
!
|
|
INTEGER :: i
|
|
REAL(DP) :: rr
|
|
!
|
|
rr = r*r
|
|
!
|
|
rho = 0.D0
|
|
!
|
|
DO i = MAX( 3-ltot, 1 ), nqf
|
|
rho = rho + qfcoef(i)*rr**(i-3+ltot)*(i-1+ltot)*(i-2+ltot)
|
|
END DO
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE setqfcorrptsecond
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE addusdens_r()
|
|
!------------------------------------------------------------------------
|
|
!
|
|
! ... This routine adds to the charge density the part which is due to
|
|
! ... the US augmentation.
|
|
!
|
|
USE ions_base, ONLY : nat, ityp
|
|
USE cell_base, ONLY : omega
|
|
USE lsda_mod, ONLY : nspin
|
|
USE scf, ONLY : rho
|
|
USE klist, ONLY : nelec
|
|
USE gvect, ONLY : nr1, nr2, nr3
|
|
USE uspp, ONLY : okvan, becsum
|
|
USE uspp_param, ONLY : upf, nh
|
|
USE noncollin_module, ONLY : noncolin
|
|
USE spin_orb, ONLY : domag
|
|
USE mp_global, ONLY : intra_pool_comm
|
|
USE mp, ONLY : mp_sum
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: ia, nt, ir, irb, ih, jh, ijh, is, nspin0, mbia, nhnt, iqs
|
|
REAL(DP) :: charge
|
|
!
|
|
!
|
|
IF ( .NOT. okvan ) RETURN
|
|
!
|
|
CALL start_clock( 'addusdens' )
|
|
!
|
|
nspin0 = nspin
|
|
!
|
|
IF ( noncolin .AND..NOT. domag ) nspin0 = 1
|
|
!
|
|
DO is = 1, nspin0
|
|
!
|
|
iqs = 0
|
|
!
|
|
DO ia = 1, nat
|
|
!
|
|
mbia = maxbox(ia)
|
|
!
|
|
IF ( mbia == 0 ) CYCLE
|
|
!
|
|
nt = ityp(ia)
|
|
!
|
|
IF ( .NOT. upf(nt)%tvanp ) CYCLE
|
|
!
|
|
nhnt = nh(nt)
|
|
!
|
|
ijh = 0
|
|
!
|
|
DO ih = 1, nhnt
|
|
DO jh = ih, nhnt
|
|
!
|
|
ijh = ijh + 1
|
|
!
|
|
DO ir = 1, mbia
|
|
!
|
|
irb = box(ir,ia)
|
|
iqs = iqs + 1
|
|
!
|
|
rho%of_r(irb,is) = rho%of_r(irb,is) + qsave(iqs)*becsum(ijh,ia,is)
|
|
END DO
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
END DO
|
|
!
|
|
! ... check the integral of the total charge
|
|
!
|
|
charge = SUM( rho%of_r(:,1:nspin0) )*omega / ( nr1*nr2*nr3 )
|
|
!
|
|
CALL mp_sum( charge , intra_pool_comm )
|
|
!
|
|
IF ( ABS( charge - nelec ) / charge > 1.D-4 ) THEN
|
|
!
|
|
! ... the error on the charge is too large
|
|
!
|
|
CALL errore( 'addusdens_r', 'charge is wrong: increase ecutrho', 1 )
|
|
!
|
|
ELSE
|
|
!
|
|
! ... rescale the density to impose the correct number of electrons
|
|
!
|
|
rho%of_r(:,:) = rho%of_r(:,:) / charge * nelec
|
|
!
|
|
END IF
|
|
!
|
|
CALL stop_clock( 'addusdens' )
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE addusdens_r
|
|
!
|
|
END MODULE realus
|