Commit 9c87cf71 authored by Fabrizio Ferrari's avatar Fabrizio Ferrari

full lsda rho conversion

parent 74f7a0c0
......@@ -186,6 +186,14 @@
TRIM(tmp_dir), TRIM(prefix), ndr,postfix
CALL read_rhog ( filename, root_bgrp, intra_bgrp_comm, &
ig_l2g, nspin, rhog )
!
!^^ ... TEMPORARY FIX (newlsda) ...
IF ( nspin==2 ) THEN
rhog(:,1) = ( rhog(:,1) + rhog(:,2) )*0.5d0
rhog(:,2) = rhog(:,1) - rhog(:,2)
ENDIF
!^^.......................
!
CALL rho_g2r ( dfftp, rhog, rhor )
rhopr = rhor
first = .FALSE.
......
......@@ -460,10 +460,21 @@ MODULE cp_restart_new
CALL rho_r2g (dfftp,rho, rhog)
filename = TRIM(dirname) // 'charge-density'
! Only the first band group collects and writes
IF ( my_bgrp_id == root_bgrp_id ) CALL write_rhog &
IF ( my_bgrp_id == root_bgrp_id ) THEN
!
!^^ ... TEMPORARY FIX (newlsda) ...
IF ( lsda ) THEN
rhog(:,1) = rhog(:,1) + rhog(:,2)
rhog(:,2) = rhog(:,1) - rhog(:,2)*2._dp
ENDIF
!^^.......................
!
CALL write_rhog &
( filename, root_bgrp, intra_bgrp_comm, &
tpiba*b1, tpiba*b2, tpiba*b3, gamma_only, &
mill, ig_l2g, rhog, ecutrho )
ENDIF
!
DEALLOCATE ( rhog )
END IF
......
......@@ -117,7 +117,23 @@ SUBROUTINE vofrho_x( nfi, rhor, drhor, rhog, drhog, rhos, rhoc, tfirst, &
CALL start_clock( 'ts_vdw' )
ALLOCATE (stmp(3,nat))
stmp(:,:) = tau0(:,ind_bck(:))
CALL tsvdw_calculate(stmp,rhor)
!
!^^ ... TEMPORARY FIX (newlsda) ...
IF ( nspin==2 ) THEN
rhor(:,1) = rhor(:,1) + rhor(:,2)
rhor(:,2) = rhor(:,1) - rhor(:,2)*2._dp
ENDIF
!^^.......................
!
CALL tsvdw_calculate(stmp,rhor(:,1), nspin)
!
!^^ ... TEMPORARY FIX ...
IF ( nspin==2 ) THEN
rhor(:,1) = ( rhor(:,1) + rhor(:,2) )*0.5_dp
rhor(:,2) = rhor(:,1) - rhor(:,2)
ENDIF
!^^.......................
!
DEALLOCATE (stmp)
CALL stop_clock( 'ts_vdw' )
!
......@@ -385,14 +401,29 @@ SUBROUTINE vofrho_x( nfi, rhor, drhor, rhog, drhog, rhos, rhoc, tfirst, &
END DO
denlc(:,:) = 0.0_dp
inlc = get_inlc()
!
!^^ ... TEMPORARY FIX (newlsda) ...
IF ( nspin==2 ) THEN
rhosave(:,1) = rhosave(:,1) + rhosave(:,2)
rhosave(:,2) = rhosave(:,1) - rhosave(:,2)*2._dp
ENDIF
!^^.......................
!
if (inlc==1 .or. inlc==2) then
if (nspin>2) call errore('stres_vdW_DF', 'vdW+DF non implemented in spin polarized calculations',1)
CALL stress_vdW_DF(rhosave, rhocsave, nspin, denlc )
CALL stress_vdW_DF(rhosave(:,1), rhocsave, nspin, denlc )
elseif (inlc == 3) then
if (nspin>2) call errore('stress_rVV10', 'rVV10 non implemented with nspin>2',1)
CALL stress_rVV10(rhosave, rhocsave, nspin, denlc )
CALL stress_rVV10(rhosave(:,1), rhocsave, nspin, denlc )
end if
!
!^^ ... TEMPORARY FIX ...
IF ( nspin==2 ) THEN
rhosave(:,1) = ( rhosave(:,1) + rhosave(:,2) )*0.5_dp
rhosave(:,2) = rhosave(:,1) - rhosave(:,2)
ENDIF
!^^.......................
!
dxc(:,:) = dxc(:,:) - omega/e2 * MATMUL(denlc,TRANSPOSE(ainv))
END IF
DEALLOCATE ( rhocsave, rhosave )
......
......@@ -24,7 +24,7 @@
USE io_files, ONLY : tmp_dir
USE klist, ONLY : xk, nks, nkstot
USE lsda_mod, ONLY : nspin, starting_magnetization
USE scf, ONLY : v, vrs, vltot, rho, kedtau, rhoz_or_updw
USE scf, ONLY : v, vrs, vltot, rho, kedtau
USE gvect, ONLY : ngm
USE symm_base, ONLY : nsym, s, irt, t_rev, time_reversal, invs, sr, &
inverse_s
......@@ -125,12 +125,8 @@
!
! 3.1) Setup all gradient correction stuff
!
IF ( nspin == 2 ) CALL rhoz_or_updw( rho, 'r_and_g', 'rhoz_updw' )
!
CALL setup_dgc
!
IF ( nspin == 2 ) CALL rhoz_or_updw( rho, 'r_and_g', 'updw_rhoz' )
!
! 4) Computes the inverse of each matrix of the crystal symmetry group
!
CALL inverse_s()
......
......@@ -33,7 +33,7 @@ SUBROUTINE energies_xc( lda, n, m, psi, e_xc, e_h,ispin )
USE lsda_mod, ONLY : current_spin
USE gvect, ONLY : gstart
USE io_global, ONLY :stdout
USE scf, ONLY : rho, vltot, vrs, rho_core,rhog_core, scf_type, rhoz_or_updw
USE scf, ONLY : rho, vltot, vrs, rho_core,rhog_core, scf_type
USE constants, ONLY :rytoev
USE io_files, ONLY : diropn
USE mp, ONLY : mp_sum, mp_barrier
......@@ -111,8 +111,6 @@ SUBROUTINE energies_xc( lda, n, m, psi, e_xc, e_h,ispin )
! ... the local potential V_Loc psi. First the psi in real space
!set exchange and correlation potential
if(.not.allocated(psic)) write(stdout,*) 'psic not allocated'
!^
IF (nspin == 2) CALL rhoz_or_updw( rho, 'r_and_g', 'rhoz_updw' )
!
if (dft_is_meta()) then
! call v_xc_meta( rho, rho_core, rhog_core, etxc, vtxc, v%of_r, v%kin_r )
......@@ -120,9 +118,6 @@ SUBROUTINE energies_xc( lda, n, m, psi, e_xc, e_h,ispin )
CALL v_xc( rho, rho_core, rhog_core, etxc, vtxc, vr )
endif
!
IF (nspin == 2) CALL rhoz_or_updw( rho, 'r_and_g', 'updw_rhoz' )
!^
do is=1,nspin
vrs(:,is)=vr(:,is)
if(doublegrid) call fft_interpolate(dfftp, vrs(:,is),dffts,vrs(:,is)) ! interpolate from dense to smooth
......@@ -362,8 +357,6 @@ SUBROUTINE energies_xc( lda, n, m, psi, e_xc, e_h,ispin )
if(.not.allocated(vr)) write(stdout,*) 'vr not allocated'
allocate(rho_fake_core(dfftp%nnr))
rho_fake_core(:)=0.d0
!^
IF (nspin == 2) CALL rhoz_or_updw( rho, 'r_and_g', 'rhoz_updw' )
!
if (dft_is_meta()) then
! call v_xc_meta( rho, rho_core, rhog_core, etxc, vtxc, v%of_r, v%kin_r )
......@@ -371,9 +364,6 @@ SUBROUTINE energies_xc( lda, n, m, psi, e_xc, e_h,ispin )
CALL v_xc( rho, rho_core, rhog_core, etxc, vtxc, vr )
endif
!
IF (nspin == 2) CALL rhoz_or_updw( rho, 'r_and_g', 'updw_rhoz' )
!^
deallocate(rho_fake_core)
......
......@@ -51,7 +51,7 @@ SUBROUTINE hp_setup_q()
USE cell_base, ONLY : at, bg
USE io_global, ONLY : stdout
USE lsda_mod, ONLY : nspin
USE scf, ONLY : v, vrs, vltot, rho, kedtau, rhoz_or_updw
USE scf, ONLY : v, vrs, vltot, rho, kedtau
USE fft_base, ONLY : dfftp
USE gvect, ONLY : ngm
USE gvecs, ONLY : doublegrid
......@@ -95,14 +95,8 @@ SUBROUTINE hp_setup_q()
!
! 5) Setup gradient correction stuff
!
!^
IF (nspin == 2) CALL rhoz_or_updw( rho, 'r_and_g', 'rhoz_updw' )
!
CALL setup_dgc()
!
IF (nspin == 2) CALL rhoz_or_updw( rho, 'r_and_g', 'updw_rhoz' )
!^
!
! 6) Compute the inverse of each matrix of the crystal symmetry group
!
CALL inverse_s()
......
......@@ -52,7 +52,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol)
REAL(DP), PARAMETER :: eps = 1.0d-8
INTEGER :: na, n ,l, nt, nah, ikb , m, m1, m2, ibnd, ib, ig, jkb, i, &
ihubst, ihubst1, ihubst2, icart, op_spin, npw
REAL(DP) :: nsaux, sgn
REAL(DP) :: nsaux
REAL(DP), ALLOCATABLE :: xyz(:,:), gk(:,:), g2k(:)
COMPLEX(DP), ALLOCATABLE :: dkwfcbessel(:,:), dkwfcylmr(:,:), dkwfcatomk(:,:), &
dpqq26(:,:), dpqq38(:,:), dpqq47(:,:), dkvkbbessel(:,:), &
......@@ -262,8 +262,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol)
!
trm = (0.d0, 0.d0)
!
sgn= REAL( 2*MOD(current_spin,2)-1 )
nsaux = ( rho%ns(m1, m2, 1, nah) + sgn*rho%ns(m1, m2, nspin, nah) )*0.5d0
nsaux = rho%ns(m1, m2, current_spin, nah)
!
DO ibnd = 1, nbnd_occ(ik)
trm(:,ibnd) = aux_1234(:) * proj1(ibnd,ihubst2) + & ! term_1234
......@@ -323,8 +322,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol)
!
trm = (0.d0, 0.d0)
!
sgn = REAL( 2*MOD(op_spin,2)-1 )
nsaux = ( rho%ns(m1, m2, 1, nah) + sgn*rho%ns(m1, m2, nspin, nah) )*0.5d0
nsaux = rho%ns(m1, m2, op_spin, nah)
!
DO ibnd = 1, nbnd_occ(ik)
trm(:,ibnd) = aux_1234(:) * proj1(ibnd,ihubst2) + & ! term_1234
......
......@@ -35,7 +35,7 @@ subroutine dgradcorr (dfft, rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, &
COMPLEX(DP), INTENT(INOUT) :: dvxc (dfft%nnr, nspin)
real(DP), parameter :: epsr = 1.0d-6, epsg = 1.0d-10
real(DP) :: grho2, seg, seg0, amag
real(DP) :: grho2, seg, seg0, amag, sgn(2)
complex(DP) :: s1, fact, term
complex(DP) :: a (2, 2, 2), b (2, 2, 2, 2), c (2, 2, 2), &
ps (2, 2), ps1 (3, 2, 2), ps2 (3, 2, 2, 2)
......@@ -57,6 +57,8 @@ subroutine dgradcorr (dfft, rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, &
allocate (gdrho( 3, dfft%nnr, nspin0))
allocate (h( 3, dfft%nnr, nspin0))
allocate (dh( dfft%nnr))
sgn(1)=1.d0 ; sgn(2)=-1.d0
h (:, :, :) = (0.d0, 0.d0)
if (noncolin.and.domag) then
......@@ -98,7 +100,10 @@ subroutine dgradcorr (dfft, rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, &
ELSE
DO is = 1, nspin0
CALL fft_qgradient (dfft, drho(1,is), xq, g, gdrho (1, 1, is) )
rhoout(:,is)=rho(:,is)
!
! rhoout, if LSDA, is in (up,down) format
!
rhoout(:,is)=( rho(:,1) + sgn(is)*rho(:,nspin0) )*0.5_dp
drhoout(:,is)=drho(:,is)
ENDDO
ENDIF
......
......@@ -26,7 +26,7 @@ subroutine dv_of_drho (dvscf, add_nlcc, drhoc)
USE cell_base, ONLY : tpiba2, omega
USE noncollin_module, ONLY : nspin_lsda, nspin_mag, nspin_gga
USE funct, ONLY : dft_is_gradient, dft_is_nonlocc
USE scf, ONLY : rho, rho_core, rhoz_or_updw
USE scf, ONLY : rho, rho_core
USE uspp, ONLY : nlcc_any
USE control_flags, ONLY : gamma_only
USE martyna_tuckerman, ONLY : wg_corr_h, do_comp_mt
......@@ -96,27 +96,11 @@ subroutine dv_of_drho (dvscf, add_nlcc, drhoc)
! NB: If nlcc=.true. we need to add here its contribution.
! grho contains already the core charge
!
if ( dft_is_gradient() ) then
!^
IF (nspin_lsda == 2) CALL rhoz_or_updw( rho, 'only_r', 'rhoz_updw' )
!
call dgradcorr &
(dfftp, rho%of_r, grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, xq, &
dvscf, nspin_mag, nspin_gga, g, dvaux)
!
IF (nspin_lsda == 2) CALL rhoz_or_updw( rho, 'only_r', 'updw_rhoz' )
!^
endif
if ( dft_is_gradient() ) call dgradcorr(dfftp, rho%of_r, grho, dvxc_rr, &
dvxc_sr, dvxc_ss, dvxc_s, xq, dvscf, &
nspin_mag, nspin_gga, g, dvaux)
!
if (dft_is_nonlocc()) then
!^
IF (nspin_lsda == 2) CALL rhoz_or_updw( rho, 'only_r', 'rhoz_updw' )
!
call dnonloccorr(rho%of_r, dvscf, xq, dvaux)
!
IF (nspin_lsda == 2) CALL rhoz_or_updw( rho, 'only_r', 'updw_rhoz' )
!^
endif
if ( dft_is_nonlocc() ) call dnonloccorr(rho%of_r, dvscf, xq, dvaux)
!
if (nlcc_any.and.add_nlcc) then
rho%of_r(:, 1) = rho%of_r(:, 1) - rho_core (:)
......
......@@ -20,9 +20,9 @@ subroutine setup_dgc
USE fft_interfaces, ONLY : fwfft
USE gvect, ONLY : ngm, g
USE spin_orb, ONLY : domag
USE scf, ONLY : rho, rho_core, rhog_core
USE scf, ONLY : rho, rho_core, rhog_core, rhoz_or_updw
USE noncollin_module, ONLY : noncolin, ux, nspin_gga, nspin_mag
USE wavefunctions, ONLY : psic
USE wavefunctions, ONLY : psic
USE kinds, ONLY : DP
USE funct, ONLY : dft_is_gradient, gcxc, gcx_spin, &
gcc_spin, dgcxc, dgcxc_spin
......@@ -36,7 +36,7 @@ subroutine setup_dgc
v1x, v2x, v1c, v2c, vrrx, vsrx, vssx, vrrc, vsrc, vssc, v1xup, &
v1xdw, v2xup, v2xdw, v1cup, v1cdw, vrrxup, vrrxdw, vrsxup, vrsxdw, &
vssxup, vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vrzcup, vrzcdw, &
amag, seg, seg0
amag, seg, seg0, sgn(2)
COMPLEX(DP), ALLOCATABLE :: rhogout(:,:)
real(DP), allocatable :: rhoout(:,:)
real (DP), parameter :: epsr = 1.0d-6, epsg = 1.0d-10
......@@ -64,6 +64,7 @@ subroutine setup_dgc
dvxc_ss(:,:,:) = 0.d0
dvxc_s (:,:,:) = 0.d0
grho (:,:,:) = 0.d0
sgn(1)=1.d0 ; sgn(2)=-1.d0
!
! add rho_core
!
......@@ -86,21 +87,29 @@ subroutine setup_dgc
END DO
DEALLOCATE(rhogout)
ELSE
!
! for convenience, if LSDA, rhoout is kept in (up,down) format
!
do is = 1, nspin_gga
rhoout(:,is) = rho%of_r(:,is)
rhoout(:,is) = ( rho%of_r(:,1) + sgn(is)*rho%of_r(:,nspin_gga) )*0.5d0
enddo
!
! if LSDA rho%of_g is temporarily converted in (up,down) format
!
call rhoz_or_updw(rho, 'only_g', '->updw')
!
if (nlcc_any) then
do is = 1, nspin_gga
rhoout(:,is) = fac * rho_core(:) + rho%of_r(:,is)
rhoout(:,is) = fac * rho_core(:) + rhoout(:,is)
rho%of_g(:,is) = fac * rhog_core(:) + rho%of_g(:,is)
enddo
endif
!
do is = 1, nspin_gga
call fft_gradient_g2r (dfftp, rho%of_g (1, is), g, grho (1, 1, is) )
enddo
END IF
do k = 1, dfftp%nnr
grho2 (1) = grho (1, k, 1) **2 + grho (2, k, 1) **2 + grho (3, k, 1) **2
if (nspin_gga == 1) then
......@@ -167,6 +176,9 @@ subroutine setup_dgc
rho%of_g(:,is) = rho%of_g(:,is) - fac * rhog_core(:)
enddo
endif
!
CALL rhoz_or_updw(rho, 'only_g', '->rhoz')
!
endif
DEALLOCATE(rhoout)
......
......@@ -2897,9 +2897,9 @@ subroutine nlc (rho_valence, rho_core, nspin, enl, vnl, v)
elseif (inlc == 3) then
if(imeta == 0) then
call xc_rVV10 (rho_valence, rho_core, nspin, enl, vnl, v)
call xc_rVV10 (rho_valence(:,1), rho_core, nspin, enl, vnl, v)
else
call xc_rVV10 (rho_valence, rho_core, nspin, enl, vnl, v, 15.7_dp)
call xc_rVV10 (rho_valence(:,1), rho_core, nspin, enl, vnl, v, 15.7_dp)
endif
else
enl = 0.0_DP
......
......@@ -591,7 +591,7 @@ PRIVATE :: GetVdWParam
!--------------------------------------------------------------------------------------------------------------
!
!--------------------------------------------------------------------------------------------------------------
SUBROUTINE tsvdw_calculate(tauin, rhor)
SUBROUTINE tsvdw_calculate(tauin, rhor, nspin)
!--------------------------------------------------------------------------------------------------------------
! TS-vdW Management Code: Manages entire calculation of TS-vdW energy, wavefunction forces, and ion forces via
! calls to PRIVATE subroutines below (called in each MD step). The calls to tsvdw_initialize and tsvdw_finalize
......@@ -602,7 +602,8 @@ PRIVATE :: GetVdWParam
!
! I/O variables
!
REAL(DP), INTENT(IN) :: rhor(:,:)
REAL(DP), INTENT(IN) :: rhor(:)
INTEGER, INTENT(IN) :: nspin
REAL(DP) :: tauin(3,nat)
!
! Parallel initialization...
......@@ -619,7 +620,7 @@ PRIVATE :: GetVdWParam
!
! Obtain molecular charge density given on the real-space mesh...
!
CALL tsvdw_rhotot( rhor )
CALL tsvdw_rhotot( rhor, nspin )
!
! Determine spherical atomic integration domains and atom overlap (bit array)...
! Compute molecular pro-density (superposition of atomic densities) on the real-space mesh...
......@@ -969,36 +970,30 @@ PRIVATE :: GetVdWParam
!--------------------------------------------------------------------------------------------------------------
!
!--------------------------------------------------------------------------------------------------------------
SUBROUTINE tsvdw_rhotot( rhor )
SUBROUTINE tsvdw_rhotot( rhor, nspin )
!--------------------------------------------------------------------------------------------------------------
!
IMPLICIT NONE
!
REAL(DP), INTENT(IN) :: rhor(:,:)
REAL(DP), INTENT(IN) :: rhor(:)
INTEGER, INTENT(IN) :: nspin
!
! Local variables
!
INTEGER :: ir,ierr,nspin
REAL(DP), DIMENSION(:), ALLOCATABLE :: rhor_tmp1,rhor_tmp2
INTEGER :: ir,ierr
REAL(DP), DIMENSION(:), ALLOCATABLE :: rhor_tmp
!
CALL start_clock('tsvdw_rhotot')
!
! Initialization of rhotot array (local copy of the real-space charge density)...
!
ALLOCATE(rhotot(nr1*nr2*nr3)); rhotot=0.0_DP
nspin = SIZE(rhor,2)
IF ( nspin < 1 .OR. nspin > 2 ) CALL errore ('tsvdw','invalid nspin',1)
#if defined(__MPI)
!
! Initialization of rhor_tmp temporary buffers...
!
ALLOCATE(rhor_tmp1(nr1*nr2*nr3)); rhor_tmp1=0.0_DP
!
IF (nspin.EQ.2) THEN
!
ALLOCATE(rhor_tmp2(nr1*nr2*nr3)); rhor_tmp2=0.0_DP
!
END IF
ALLOCATE(rhor_tmp(nr1*nr2*nr3)); rhor_tmp=0.0_DP
!
! Collect distributed rhor and broadcast to all processors...
!
......@@ -1016,36 +1011,20 @@ PRIVATE :: GetVdWParam
!
END DO
!
CALL MPI_ALLGATHERV(rhor(1,1),dfftp%nr3p(me_bgrp+1)*nr1*nr2,&
MPI_DOUBLE_PRECISION,rhor_tmp1(1),recvcount,rdispls,&
CALL MPI_ALLGATHERV(rhor(1),dfftp%nr3p(me_bgrp+1)*nr1*nr2,&
MPI_DOUBLE_PRECISION,rhor_tmp(1),recvcount,rdispls,&
MPI_DOUBLE_PRECISION,intra_bgrp_comm,ierr)
!
IF (nspin.EQ.2) THEN
!
CALL MPI_ALLGATHERV(rhor(1,2),dfftp%nr3p(me_bgrp+1)*nr1*nr2,&
MPI_DOUBLE_PRECISION,rhor_tmp2(1),recvcount,rdispls,&
MPI_DOUBLE_PRECISION,intra_bgrp_comm,ierr)
!
END IF
!
! Transfer rhor temporary arrays to rhotot array...
!
rhotot=rhor_tmp1
!
IF (nspin.EQ.2) THEN
!
rhotot=rhotot+rhor_tmp2
!
END IF
rhotot=rhor_tmp
!
! Clean-up temporary arrays...
!
IF (ALLOCATED(rhor_tmp1)) DEALLOCATE(rhor_tmp1)
IF (ALLOCATED(rhor_tmp2)) DEALLOCATE(rhor_tmp2)
IF (ALLOCATED(rhor_tmp)) DEALLOCATE(rhor_tmp)
!
#else
rhotot(:) = rhor(:,1)
IF (nspin == 2) rhotot(:) = rhotot(:) + rhor(:,2)
rhotot(:) = rhor(:)
#endif
CALL stop_clock('tsvdw_rhotot')
!
......
......@@ -53,7 +53,7 @@ CONTAINS
!! Local variables
!! ----------------------------------------------------------------------------------
! _
real(dp), intent(IN) :: rho_valence(:,:) !
real(dp), intent(IN) :: rho_valence(:) !
real(dp), intent(IN) :: rho_core(:) ! PWSCF input variables
INTEGER, INTENT(IN) :: nspin !
real(dp), intent(inout) :: etxc, vtxc, v(:,:) !_
......@@ -129,12 +129,8 @@ CONTAINS
!! ---------------------------------------------------------------------------------------
!! Add together the valence and core charge densities to get the total charge density
!total_rho = rho_valence(:,1) + rho_core(:)
if (nspin == 2) then
total_rho = rho_valence(:,1) + rho_valence(:,2) + rho_core(:)
else
total_rho = rho_valence(:,1) + rho_core(:)
endif
!
total_rho = rho_valence(:) + rho_core(:)
!! -------------------------------------------------------------------------
!! Here we calculate the gradient in reciprocal space using FFT
......@@ -207,13 +203,8 @@ CONTAINS
grid_cell_volume = omega/(dfftp%nr1*dfftp%nr2*dfftp%nr3)
do i_grid = 1, dfftp%nnr
vtxc = vtxc + grid_cell_volume*rho_valence(i_grid,1)*potential(i_grid)
vtxc = vtxc + grid_cell_volume*rho_valence(i_grid)*potential(i_grid)
end do
if (nspin==2) then
do i_grid = 1, dfftp%nnr
vtxc = vtxc + grid_cell_volume*rho_valence(i_grid,2)*potential(i_grid)
end do
endif
deallocate(potential)
......@@ -240,7 +231,7 @@ CONTAINS
implicit none
real(dp), intent(IN) :: rho_valence(:,:) !
real(dp), intent(IN) :: rho_valence(:) !
real(dp), intent(IN) :: rho_core(:) ! Input variables
INTEGER, INTENT(IN) :: nspin
real(dp), intent(inout) :: sigma(3,3) !
......@@ -282,13 +273,7 @@ CONTAINS
!! ---------------------------------------------------------------------------------------
!! Charge
!! ---------------------------------------------------------------------------------------
!total_rho = rho_valence(:,1) + rho_core(:)
if (nspin == 2) then
total_rho = rho_valence(:,1) + rho_valence(:,2) + rho_core(:)
else
total_rho = rho_valence(:,1) + rho_core(:)
endif
total_rho = rho_valence(:) + rho_core(:)
!! -------------------------------------------------------------------------
!! Here we calculate the gradient in reciprocal space using FFT
......
......@@ -477,8 +477,8 @@ CONTAINS
! it is only non-zero for pseudopotentials with non-local core
! corrections.
rho_up = rho_valence(:,1) + 0.5D0*rho_core(:)
rho_down = rho_valence(:,2) + 0.5D0*rho_core(:)
rho_up = ( rho_valence(:,1) + rho_valence(:,2) + rho_core(:) )*0.5D0
rho_down = ( rho_valence(:,1) - rho_valence(:,2) + rho_core(:) )*0.5D0
total_rho = rho_up + rho_down
#if defined (__SPIN_BALANCED)
......@@ -550,10 +550,10 @@ CONTAINS
grid_cell_volume = omega/(dfftp%nr1*dfftp%nr2*dfftp%nr3)
do i_grid = 1, dfftp%nnr
vtxc = vtxc + e2 * grid_cell_volume * rho_valence(i_grid,1) * potential_up (i_grid) &
+ e2 * grid_cell_volume * rho_valence(i_grid,2) * potential_down(i_grid)
end do
vtxc = vtxc + e2 * grid_cell_volume * (rho_valence(i_grid,1) + rho_valence(i_grid,2)) &
* potential_up (i_grid) &
+ e2 * grid_cell_volume * (rho_valence(i_grid,1) - rho_valence(i_grid,2)) &
* potential_down(i_grid)
deallocate( potential_up, potential_down, q0, grad_rho, grad_rho_up, &
grad_rho_down, dq0_drho_up, dq0_drho_down, thetas, &
......@@ -1543,7 +1543,7 @@ CONTAINS
implicit none
real(dp), intent(IN) :: rho_valence(:,:) !
real(dp), intent(IN) :: rho_valence(:) !
real(dp), intent(IN) :: rho_core(:) ! Input variables
integer, intent(IN) :: nspin !
real(dp), intent(inout) :: sigma(3,3) !
......@@ -1597,11 +1597,11 @@ CONTAINS
! --------------------------------------------------------------------
! Charge
total_rho = rho_valence(:,1) + rho_core(:)
total_rho = rho_valence(:) + rho_core(:)
#if defined (__SPIN_BALANCED)
if ( nspin == 2 ) then
total_rho = rho_valence(:,2) + total_rho(:)
end if
!if ( nspin == 2 ) then
! total_rho = rho_valence(:,2) + total_rho(:)
!end if
#endif
......
......@@ -13,7 +13,7 @@ SUBROUTINE cg_setupdgc
!
USE kinds, ONLY: dp
USE constants, ONLY: e2
USE scf, ONLY: rho, rho_core, rhog_core, rhoz_or_updw
USE scf, ONLY: rho, rho_core, rhog_core
USE funct, ONLY: gcxc, gcx_spin, gcc_spin, dgcxc, dgcxc_spin, dft_is_gradient
USE fft_base, ONLY: dfftp
USE gvect, ONLY: ngm, g
......@@ -24,7 +24,7 @@ SUBROUTINE cg_setupdgc
IMPLICIT NONE
INTEGER k, is
real(DP) &
& grho2(2), rh, zeta, grh2, epsr, epsg, &
& grho2(2), rh, zeta, grh2, epsr, epsg, fac(2), sgn(2), &
& sx,sc,v1x,v2x,v1c,v2c,vrrx,vsrx,vssx, &
& vrrc,vsrc,vssc, &
& v1xup,v1xdw,v2xup,v2xdw, &
......@@ -44,20 +44,30 @@ SUBROUTINE cg_setupdgc
dvxc_s (:,:,:) = 0.d0
grho (:,:,:) = 0.d0
!
! add rho_core
fac(1) = dble(mod(nspin,2)+1) ; fac(2) = 0.d0
sgn(1) = 1.d0 ; sgn(2) = -1.d0
!
! adds rho_core and, if LSDA, directly converts rho in (up,down) format
!
IF (nlcc_any) THEN
rho%of_r(:,1) = rho%of_r(:,1) + rho_core(:)
rho%of_g(:,1) = rho%of_g(:,1) +rhog_core(:)
DO is=1,nspin
rho%of_r(:,is) = ( fac(is)* rho_core(:) + rho%of_r(:,1) + &
sgn(is)*rho%of_r(:,nspin) )*is/2.d0
rho%of_g(:,is) = ( fac(is)*rhog_core(:) + rho%of_g(:,1) + &
sgn(is)*rho%of_g(:,nspin) )*is/2.d0
ENDDO
ENDIF
!
DO is=1,nspin
CALL fft_gradient_g2r (dfftp, rho%of_g(1,is), g, grho(1,1,is))
ENDDO
!
IF (nspin==1) THEN
CALL fft_gradient_g2r (dfftp, rho%of_g(1,1), g, grho(1,1,1))
DO k = 1,dfftp%nnr
grho2(1)=grho(1,k,1)**2+grho(2,k,1)**2+grho(3,k,1)**2
IF (abs(rho%of_r(k,1))>epsr.and.grho2(1)>epsg) THEN
CALL gcxc(rho%of_r(k,1),grho2(1),sx,sc,v1x,v2x,v1c,v2c)
CALL dgcxc(rho%of_r(k,1),grho2(1),vrrx,vsrx,vssx,vrrc,vsrc,vssc)
CALL gcxc(rho%of_r(k,nspin),grho2(1),sx,sc,v1x,v2x,v1c,v2c)
CALL dgcxc(rho%of_r(k,nspin),grho2(1),vrrx,vsrx,vssx,vrrc,vsrc,vssc)
dvxc_rr(k,1,1) = e2 * ( vrrx + vrrc )
dvxc_sr(k,1,1) = e2 * ( vsrx + vsrc )
dvxc_ss(k,1,1) = e2 * ( vssx + vssc )
......@@ -65,15 +75,9 @@ SUBROUTINE cg_setupdgc
ENDIF
ENDDO