2003-01-20 05:58:50 +08:00
|
|
|
!
|
2007-10-24 03:47:26 +08:00
|
|
|
! Copyright (C) 2001-2007 Quantum-Espresso group
|
2003-01-20 05:58:50 +08:00
|
|
|
! 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 .
|
|
|
|
|
!
|
2004-06-26 01:25:37 +08:00
|
|
|
#include "f_defs.h"
|
2004-06-12 21:44:18 +08:00
|
|
|
!
|
2003-01-20 05:58:50 +08:00
|
|
|
!-----------------------------------------------------------------------
|
2008-04-21 05:23:37 +08:00
|
|
|
subroutine vhpsi (ldap, np, mps, psip, hpsi)
|
2003-01-20 05:58:50 +08:00
|
|
|
!-----------------------------------------------------------------------
|
|
|
|
|
!
|
|
|
|
|
! This routine computes the Hubbard potential applied to the electronic
|
|
|
|
|
! of the current k-point, the result is added to hpsi
|
|
|
|
|
!
|
2004-06-12 21:44:18 +08:00
|
|
|
USE kinds, ONLY : DP
|
2009-04-15 15:10:31 +08:00
|
|
|
USE becmod, ONLY : calbec
|
2007-11-10 23:07:51 +08:00
|
|
|
USE ldaU, ONLY : Hubbard_lmax, Hubbard_l, HUbbard_U, Hubbard_alpha, &
|
2007-11-19 04:25:11 +08:00
|
|
|
swfcatom
|
2004-06-12 21:44:18 +08:00
|
|
|
USE lsda_mod, ONLY : nspin, current_spin
|
2007-11-19 04:25:11 +08:00
|
|
|
USE scf, ONLY : v
|
2004-06-12 21:44:18 +08:00
|
|
|
USE ions_base, ONLY : nat, ntyp => nsp, ityp
|
|
|
|
|
USE basis, ONLY : natomwfc
|
|
|
|
|
USE gvect, ONLY : gstart
|
2007-10-24 03:47:26 +08:00
|
|
|
USE uspp_param,ONLY : upf
|
2007-11-22 22:23:04 +08:00
|
|
|
USE control_flags, ONLY : gamma_only
|
2008-04-21 05:23:37 +08:00
|
|
|
USE mp_global, ONLY: intra_pool_comm
|
|
|
|
|
USE mp, ONLY: mp_sum
|
2004-06-12 21:44:18 +08:00
|
|
|
!
|
2003-01-20 05:58:50 +08:00
|
|
|
implicit none
|
2004-06-12 21:44:18 +08:00
|
|
|
!
|
2009-04-15 15:10:31 +08:00
|
|
|
integer, intent (in) :: ldap, np, mps
|
|
|
|
|
complex(DP), intent(in) :: psip (ldap, mps)
|
|
|
|
|
complex(DP), intent(inout) :: hpsi (ldap, mps)
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
|
|
|
|
integer :: ibnd, i, na, nt, n, counter, m1, m2, l
|
|
|
|
|
integer, allocatable :: offset (:)
|
2003-03-20 19:21:34 +08:00
|
|
|
! offset of localized electrons of atom na in the natomwfc ordering
|
2009-04-15 15:10:31 +08:00
|
|
|
complex(DP) :: temp
|
|
|
|
|
real(DP), allocatable :: rproj(:,:)
|
2005-08-28 22:09:42 +08:00
|
|
|
complex(DP), allocatable :: proj (:,:)
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
2009-04-15 15:10:31 +08:00
|
|
|
allocate ( offset(nat) )
|
2003-02-10 16:58:33 +08:00
|
|
|
counter = 0
|
|
|
|
|
do na = 1, nat
|
|
|
|
|
nt = ityp (na)
|
2007-10-24 03:47:26 +08:00
|
|
|
do n = 1, upf(nt)%nwfc
|
|
|
|
|
if (upf(nt)%oc (n) >= 0.d0) then
|
|
|
|
|
l = upf(nt)%lchi (n)
|
2003-02-10 16:58:33 +08:00
|
|
|
if (l.eq.Hubbard_l(nt)) offset (na) = counter
|
|
|
|
|
counter = counter + 2 * l + 1
|
2003-01-20 05:58:50 +08:00
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
|
|
|
|
!
|
2009-04-15 15:10:31 +08:00
|
|
|
if (counter /= natomwfc) call errore ('vhpsi', 'nstart<>counter', 1)
|
|
|
|
|
IF (gamma_only) THEN
|
|
|
|
|
ALLOCATE (rproj(natomwfc,mps) )
|
|
|
|
|
CALL calbec (np, swfcatom, psip,rproj)
|
|
|
|
|
ELSE
|
|
|
|
|
ALLOCATE ( proj(natomwfc,mps) )
|
|
|
|
|
CALL calbec (np, swfcatom, psip, proj)
|
|
|
|
|
END IF
|
2008-04-21 05:23:37 +08:00
|
|
|
do ibnd = 1, mps
|
2003-02-10 16:58:33 +08:00
|
|
|
do na = 1, nat
|
|
|
|
|
nt = ityp (na)
|
|
|
|
|
if (Hubbard_U(nt).ne.0.d0 .or. Hubbard_alpha(nt).ne.0.d0) then
|
|
|
|
|
do m1 = 1, 2 * Hubbard_l(nt) + 1
|
2007-11-10 23:07:51 +08:00
|
|
|
temp = 0.d0
|
2004-02-12 20:32:06 +08:00
|
|
|
if (gamma_only) then
|
2009-04-15 15:10:31 +08:00
|
|
|
do m2 = 1, 2 * Hubbard_l(nt) + 1
|
|
|
|
|
temp = temp + v%ns( m1, m2, current_spin, na) * &
|
|
|
|
|
rproj (offset(na)+m2, ibnd)
|
|
|
|
|
enddo
|
2004-02-12 20:32:06 +08:00
|
|
|
call DAXPY (2*np, temp, swfcatom(1,offset(na)+m1), 1, &
|
|
|
|
|
hpsi(1,ibnd), 1)
|
|
|
|
|
else
|
2009-04-15 15:10:31 +08:00
|
|
|
do m2 = 1, 2 * Hubbard_l(nt) + 1
|
|
|
|
|
temp = temp + v%ns( m1, m2, current_spin, na) * &
|
|
|
|
|
proj (offset(na)+m2, ibnd)
|
|
|
|
|
enddo
|
2004-02-12 20:32:06 +08:00
|
|
|
call ZAXPY (np, temp, swfcatom(1,offset(na)+m1), 1, &
|
2003-01-20 05:58:50 +08:00
|
|
|
hpsi(1,ibnd), 1)
|
2004-02-12 20:32:06 +08:00
|
|
|
endif
|
2003-01-20 05:58:50 +08:00
|
|
|
enddo
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
enddo
|
2009-04-15 15:10:31 +08:00
|
|
|
IF (gamma_only) THEN
|
|
|
|
|
DEALLOCATE (offset, rproj)
|
|
|
|
|
ELSE
|
|
|
|
|
DEALLOCATE (offset, proj)
|
|
|
|
|
ENDIF
|
2003-02-08 00:04:36 +08:00
|
|
|
return
|
2003-01-20 05:58:50 +08:00
|
|
|
|
|
|
|
|
end subroutine vhpsi
|
|
|
|
|
|
