scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Revert "Merge branch 'commutator' into 'develop'" 

This reverts merge request !1368
This commit is contained in:
Pietro Delugas 2021-04-02 16:03:58 +00:00
parent c395d46c8d
commit 78fc480a78
73 changed files with 545 additions and 536 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -45,6 +45,6 @@ archive/wannier90-*tgz
wannier90-*
devicexlib
tempdir
tags
EPW/src/tags
EPW/src/tmp
LAXlib/*.fh

6
CPV/src/bforceion.f90
View File

@ -24,7 +24,7 @@ subroutine bforceion(fion,tfor,ipol,qmatinv,bec0,becdr,gqq,evalue)
use ions_base, only : nax, na, nsp, nat, ityp
use uspp_param, only: upf, nh, nhm
use uspp, only : nkb, ofsbeta
use uspp, only : nkb, indv_ijkb0
use kinds, only : dp
use constants, only :
use cell_base, only: at, alat
@ -61,8 +61,8 @@ subroutine bforceion(fion,tfor,ipol,qmatinv,bec0,becdr,gqq,evalue)
IF(upf(is)%tvanp) THEN
do iv= 1,nh(is)
do jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
temp=(0.d0,0.d0)
temp1=(0.d0,0.d0)
temp2=(0.d0,0.d0)

10
CPV/src/cg_sub.f90
View File

@ -39,7 +39,7 @@
USE io_files, ONLY : tmp_dir, prefix
use uspp, only : nkb, nkbus, &
betae => vkb, rhovan => becsum, &
deeq, qq_nt, nlcc_any, ofsbeta
deeq, qq_nt, nlcc_any, indv_ijkb0
use uspp_param, only : nh, upf
use cg_module, only : ene_ok, maxiter,niter_cg_restart, &
conv_thr, passop, enever, itercg,c0old
@ -391,8 +391,8 @@
IF(upf(is)%tvanp) THEN
do iv=1,nh(is)
do jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
gamma=gamma+ qq_nt(iv,jv,is)*becm(inl,i)*bec0(jnl,i)
end do
end do
@ -452,8 +452,8 @@
IF( upf(is)%tvanp ) THEN
do iv=1,nh(is)
do jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
gamma=gamma+ qq_nt(iv,jv,is)*becm(inl,i+istart-1)*bec0(jnl,jj+istart-1)*fmat_(j,i)
end do
end do

28
CPV/src/cglib.f90
View File

@ -90,7 +90,7 @@
use kinds, only: dp
use electrons_base, only: nudx, nspin, nupdwn, iupdwn, nx => nbspx, n => nbsp
use uspp_param, only: nh, upf
use uspp, only : nkb, qq_nt, ofsbeta
use uspp, only : nkb, qq_nt, indv_ijkb0
use gvecw, only: ngw
use ions_base, only: nat, ityp
USE cp_main_variables, ONLY: idesc
@ -115,7 +115,7 @@
nrl = idesc( LAX_DESC_NRL, iss )
comm_rot = idesc( LAX_DESC_COMM, iss )
CALL protate ( c0, bec, c0diag, becdiag, ngw, nss, istart, z0(:,:,iss), nrl, &
ityp, nat, ofsbeta, nh, np_rot, me_rot, comm_rot )
ityp, nat, indv_ijkb0, nh, np_rot, me_rot, comm_rot )
END DO
CALL stop_clock( 'rotate' )
@ -172,7 +172,7 @@ subroutine pc2(a,beca,b,becb)
use mp, only: mp_sum
use electrons_base, only: n => nbsp, ispin, nupdwn, iupdwn, nspin
use uspp_param, only: nh, upf
use uspp, only :nkb, nkbus, ofsbeta
use uspp, only :nkb, nkbus, indv_ijkb0
use uspp, only :qq_nt
@ -227,8 +227,8 @@ subroutine pc2(a,beca,b,becb)
IF( upf(is)%tvanp ) THEN
do iv=1,nh(is)
do jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
qq_tmp(inl,jnl)=qq_nt(iv,jv,is)
enddo
enddo
@ -338,7 +338,7 @@ subroutine pc2(a,beca,b,becb)
use mp, only: mp_sum, mp_bcast
use electrons_base, only: n => nbsp, ispin
use uspp_param, only: nh, upf
use uspp, only :nkb,qq_nt, ofsbeta
use uspp, only :nkb,qq_nt, indv_ijkb0
use io_global, ONLY: ionode, ionode_id
implicit none
@ -372,8 +372,8 @@ subroutine pc2(a,beca,b,becb)
IF( upf(is)%tvanp ) THEN
do iv=1,nh(is)
do jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
q_matrix(inl,jnl)= qq_nt(iv,jv,is)
enddo
enddo
@ -391,8 +391,8 @@ subroutine pc2(a,beca,b,becb)
js=ityp(ja)
IF( upf(js)%tvanp ) THEN
do jv=1,nh(js)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ja) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ja) + jv
sca=0.d0
if (use_ema) then
! k_minus case
@ -459,7 +459,7 @@ subroutine pc2(a,beca,b,becb)
use io_global, only: stdout
use mp_global, only: intra_bgrp_comm
use uspp_param, only: nh, upf
use uspp, only :nkb, nkbus, qq_nt, ofsbeta
use uspp, only :nkb, nkbus, qq_nt, indv_ijkb0
use electrons_base, only: n => nbsp
use gvecw, only: ngw
use constants, only: pi, fpi
@ -490,7 +490,7 @@ subroutine pc2(a,beca,b,becb)
is=ityp(ia)
IF( upf(is)%tvanp ) THEN
do iv=1,nh(is)
inl = ofsbeta(ia) + iv
inl = indv_ijkb0(ia) + iv
do i=1,n
becktmp = 0.0d0
do ig=1,ngw
@ -634,7 +634,7 @@ subroutine pc2(a,beca,b,becb)
use io_global, only: stdout
use mp_global, only: intra_bgrp_comm
use uspp_param, only: nh, upf
use uspp, only :nkb, nkbus, qq_nt, ofsbeta
use uspp, only :nkb, nkbus, qq_nt, indv_ijkb0
use electrons_base, only: n => nbsp
use gvecw, only: ngw
use constants, only: pi, fpi
@ -669,7 +669,7 @@ subroutine pc2(a,beca,b,becb)
is = ityp(ia)
IF( upf(is)%tvanp ) THEN
do iv=1,nh(is)
inl = ofsbeta(ia) + iv
inl = indv_ijkb0(ia) + iv
do i=1,n
becktmp = 0.0d0
do ig=1,ngw

4
CPV/src/cp_interfaces.f90
View File

@ -823,11 +823,11 @@
INTERFACE protate
SUBROUTINE protate_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, nrl, &
ityp, nat, ofsbeta, nh, np_rot, me_rot, comm_rot )
ityp, nat, indv_ijkb0, nh, np_rot, me_rot, comm_rot )
USE kinds, ONLY: DP
IMPLICIT NONE
INTEGER, INTENT(IN) :: ngwl, nss, nrl, noff
INTEGER, INTENT(IN) :: ityp(:), nat, ofsbeta(:), nh(:)
INTEGER, INTENT(IN) :: ityp(:), nat, indv_ijkb0(:), nh(:)
INTEGER, INTENT(IN) :: np_rot, me_rot, comm_rot
COMPLEX(DP), INTENT(IN) :: c0(:,:)
COMPLEX(DP), INTENT(OUT) :: c0rot(:,:)

24
CPV/src/cplib.f90
View File

@ -900,7 +900,7 @@ subroutine nlfh_x( stress, bec_bgrp, dbec, lambda, idesc )
! contribution to the internal stress tensor due to the constraints
!
USE kinds, ONLY : DP
use uspp, ONLY : nkb, qq_nt, ofsbeta
use uspp, ONLY : nkb, qq_nt, indv_ijkb0
use uspp_param, ONLY : nh, nhm, upf
use ions_base, ONLY : nat, ityp
use electrons_base, ONLY : nbspx, nbsp, nudx, nspin, nupdwn, iupdwn, ibgrp_g2l
@ -990,7 +990,7 @@ subroutine nlfh_x( stress, bec_bgrp, dbec, lambda, idesc )
!
do iv=1,nh(is)
do jv=1,nh(is)
inl=ofsbeta(ia) + jv
inl=indv_ijkb0(ia) + jv
if(abs(qq_nt(iv,jv,is)).gt.1.e-5) then
do i = 1, nc
tmpbec(iv,i) = tmpbec(iv,i) + qq_nt(iv,jv,is) * bec( inl, i, iss )
@ -1000,7 +1000,7 @@ subroutine nlfh_x( stress, bec_bgrp, dbec, lambda, idesc )
end do
do iv=1,nh(is)
inl=ofsbeta(ia) + iv
inl=indv_ijkb0(ia) + iv
do i = 1, nr
tmpdh(i,iv) = dbec( inl, i + (iss-1)*nrcx, ii, jj )
end do
@ -1513,7 +1513,7 @@ end subroutine dylmr2_
USE ions_base, ONLY: na, nsp, nat, ityp
USE io_global, ONLY: stdout
USE gvect, ONLY: gstart
USE uspp, ONLY: nkb, qq_nt, ofsbeta
USE uspp, ONLY: nkb, qq_nt, indv_ijkb0
USE uspp_param, ONLY: nh, upf
USE mp, ONLY: mp_sum
USE mp_global, ONLY: intra_bgrp_comm, nbgrp, inter_bgrp_comm
@ -1590,8 +1590,8 @@ end subroutine dylmr2_
IF( ityp(ia) /= is ) CYCLE
DO iv=1,nh(is)
DO jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
rsum = rsum + qq_nt(iv,jv,is)*becp_tmp(inl)*becp(jnl,ibgrp_k)
END DO
END DO
@ -1720,7 +1720,7 @@ end subroutine dylmr2_
USE kinds, ONLY: DP
USE io_global, ONLY: stdout
USE ions_base, ONLY: na, nsp, nat, ityp
USE uspp, ONLY: nhsa=>nkb, qq_nt, ofsbeta
USE uspp, ONLY: nhsa=>nkb, qq_nt, indv_ijkb0
USE uspp_param, ONLY: nhm, nh, upf
USE electrons_base, ONLY: nspin, iupdwn, nupdwn, nbspx_bgrp, ibgrp_g2l, i2gupdwn_bgrp, nbspx, &
iupdwn_bgrp, nupdwn_bgrp
@ -1770,7 +1770,7 @@ end subroutine dylmr2_
!
!$omp parallel default(none), &
!$omp shared(nrrx,nhm,nrcx,nsp,na,nspin,nrr,nupdwn,iupdwn,idesc,nh,qq_nt,bec,becdr_bgrp,ibgrp_l2g,tmplam,fion_tmp), &
!$omp shared(upf, ityp,nat,ofsbeta), &
!$omp shared(upf, ityp,nat,indv_ijkb0), &
!$omp private(tmpdr,temp,tmpbec,is,k,ia,i,iss,nss,istart,ic,nc,jv,iv,inl,ir,nr)
IF( nrrx > 0 ) THEN
@ -1801,7 +1801,7 @@ end subroutine dylmr2_
ic = idesc( LAX_DESC_IC, iss )
nc = idesc( LAX_DESC_NC, iss )
DO jv=1,nh(is)
inl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + jv
DO iv=1,nh(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
DO i=1,nc
@ -1814,7 +1814,7 @@ end subroutine dylmr2_
ir = idesc( LAX_DESC_IR, iss )
nr = idesc( LAX_DESC_NR, iss )
DO iv=1,nh(is)
inl = ofsbeta(ia) + iv
inl = indv_ijkb0(ia) + iv
DO i=1,nrr(iss)
tmpdr(i,iv) = becdr_bgrp( inl, ibgrp_l2g(i,iss), k )
END DO
@ -1977,7 +1977,7 @@ end subroutine dylmr2_
USE kinds, ONLY : DP
USE ions_base, ONLY : nat, ityp
USE gvecw, ONLY : ngw
USE uspp, ONLY : beta, nhtol, ofsbeta
USE uspp, ONLY : beta, nhtol, indv_ijkb0
USE uspp_param, ONLY : nh, upf
USE gvect, ONLY : gstart
!
@ -1996,7 +1996,7 @@ end subroutine dylmr2_
is=ityp(ia)
DO iv=1,nh(is)
ci=cfact( nhtol(iv,is) + 1 )
inl = ofsbeta(ia) + iv
inl = indv_ijkb0(ia) + iv
DO ig=1,ngw
betae(ig,inl)=ci*beta(ig,iv,is)*eigr(ig,ia)
END DO

6
CPV/src/dforceb.f90
View File

@ -36,7 +36,7 @@ subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df)
use ions_base, only : nat, nax, nsp, ityp
use cell_base, only: at, alat
use uspp_param, only: nh, nhm, upf
use uspp, only : nkb, ofsbeta
use uspp, only : nkb, indv_ijkb0
use efield_module, ONLY : ctabin_missing_1,ctabin_missing_2,n_g_missing_m,&
& ctabin_missing_rev_1,ctabin_missing_rev_2
use mp_global, only: intra_bgrp_comm, nproc_bgrp
@ -201,8 +201,8 @@ subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df)
IF(upf(is)%tvanp) THEN
do iv=1,nh(is) !loop on projectors
do jv=1,nh(is) !loop on projectors
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
do j=1,n !loop on states
afrc(inl)=afrc(inl)+gqq(iv,jv,ia,is)*bec0(jnl,j)*qmat(j,i)&
& -CONJG(gqq(jv,iv,ia,is))*bec0(jnl,j)*conjg(qmat(i,j))

14
CPV/src/forces.f90
View File

@ -23,7 +23,7 @@
USE parallel_include
USE kinds, ONLY: dp
USE control_flags, ONLY: iprint
USE uspp, ONLY: nhsa=>nkb, dvan, deeq, ofsbeta
USE uspp, ONLY: nhsa=>nkb, dvan, deeq, indv_ijkb0
USE uspp_param, ONLY: nhm, nh
USE constants, ONLY: pi, fpi
USE ions_base, ONLY: nsp, na, nat, ityp
@ -295,8 +295,8 @@
DO iv = 1, nh(is)
DO jv = 1, nh(is)
dv = dvan(iv,jv,is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
IF( i + idx - 1 /= n ) THEN
dd = deeq(iv,jv,ia,iss1) + dv
af(inl,igrp) = af(inl,igrp) - fi * dd * bec(jnl,i+idx-1)
@ -348,7 +348,7 @@
USE parallel_include
USE kinds, ONLY: dp
USE control_flags, ONLY: iprint
USE uspp, ONLY: nhsa=>nkb, dvan, deeq, ofsbeta
USE uspp, ONLY: nhsa=>nkb, dvan, deeq, indv_ijkb0
USE uspp_param, ONLY: nhm, nh
USE constants, ONLY: pi, fpi
USE ions_base, ONLY: nsp, na, nat, ityp
@ -508,7 +508,7 @@
ALLOCATE( af_d( nhsa, many_fft ), aa_d( nhsa, many_fft ) )
!
!$omp parallel do default(none), &
!$omp shared(many_fft,i,n,tens,f,nat,ityp,nh,dvan,ofsbeta,deeq,af,aa,bec,ispin), &
!$omp shared(many_fft,i,n,tens,f,nat,ityp,nh,dvan,indv_ijkb0,deeq,af,aa,bec,ispin), &
!$omp private(idx,igrp,fi,fip,ia,is,iv,jv,inl,jnl,dv,dd,iss1,iss2)
DO idx = 1, 2*many_fft , 2
@ -537,8 +537,8 @@
DO iv = 1, nh(is)
DO jv = 1, nh(is)
dv = dvan(iv,jv,is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
IF( i + idx - 1 /= n ) THEN
dd = deeq(iv,jv,ia,iss1) + dv
af(inl,igrp) = af(inl,igrp) - fi * dd * bec(jnl,i+idx-1)

14
CPV/src/gram.f90
View File

@ -102,7 +102,7 @@ CONTAINS
USE ions_base, ONLY: nat, ityp
USE gvecw, ONLY: ngw
USE uspp_param, ONLY: nh, upf
USE uspp, ONLY: qq_nt, ofsbeta
USE uspp, ONLY: qq_nt, indv_ijkb0
USE mp, ONLY: mp_sum
USE mp_global, ONLY: intra_bgrp_comm
USE kinds, ONLY: DP
@ -124,7 +124,7 @@ CONTAINS
IF ( MOD( ia, nproc_bgrp ) == me_bgrp ) THEN
is = ityp(ia)
IF( upf(is)%tvanp ) THEN
indv = ofsbeta(ia)
indv = indv_ijkb0(ia)
DO iv=1,nh(is)
DO jv=1,nh(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
@ -151,7 +151,7 @@ CONTAINS
! on output: bec(i) is recalculated
!
USE ions_base, ONLY: na, nat, ityp
USE uspp, ONLY: qq_nt, ofsbeta
USE uspp, ONLY: qq_nt, indv_ijkb0
USE uspp_param, ONLY: nh, upf
USE electrons_base, ONLY: ispin, ispin_bgrp, nbspx_bgrp, ibgrp_g2l, iupdwn, nupdwn, nbspx
USE gvecw, ONLY: ngw
@ -210,12 +210,12 @@ CONTAINS
is = ityp(ia)
IF( upf(is)%tvanp ) THEN
DO iv=1,nh(is)
inl=ofsbeta(ia)+iv
inl=indv_ijkb0(ia)+iv
bec_tmp(inl) = 2.d0 * DDOT( 2*ngw, cp_bgrp(1,ibgrp_i), 1, betae(1,inl), 1) &
- g0 * DBLE(cp_bgrp(1,ibgrp_i) * CONJG(betae(1,inl)))
END DO
ELSE
inl= ofsbeta(ia)
inl= indv_ijkb0(ia)
bec_tmp( inl + 1: inl + nh(is) ) = 0.0d0
END IF
END DO
@ -233,7 +233,7 @@ CONTAINS
!$omp parallel if( (kmax - iupdwn( iss )) > omp_get_num_threads() ) default(none), &
!$omp shared(iupdwn,iss,kmax,nproc_bgrp,me_bgrp,nbspx,i,ibgrp_g2l,nh), &
!$omp shared(ofsbeta,qq_nt,na,bec_tmp,bec_bgrp,csc2,nat,ityp,upf), &
!$omp shared(indv_ijkb0,qq_nt,na,bec_tmp,bec_bgrp,csc2,nat,ityp,upf), &
!$omp private( k, is, iv, jv, ia, inl, jnl, rsum, ibgrp_k )
!$omp do
DO k = iupdwn( iss ), kmax
@ -244,7 +244,7 @@ CONTAINS
IF ( MOD( ia-1, nproc_bgrp ) == me_bgrp ) THEN
is=ityp(ia)
IF( upf(is)%tvanp ) THEN
inl = ofsbeta(ia)
inl = indv_ijkb0(ia)
DO iv=1,nh(is)
DO jv=1,nh(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN

14
CPV/src/ldaU.f90
View File

@ -14,7 +14,7 @@
!
USE kinds, ONLY: DP
USE ions_base, ONLY: nat, ityp
USE uspp, ONLY: nkb, nkbus, qq_nt, ofsbeta
USE uspp, ONLY: nkb, nkbus, qq_nt, indv_ijkb0
USE uspp_param, ONLY: nh, upf
USE gvecw, ONLY: ngw
IMPLICIT NONE
@ -39,8 +39,8 @@
DO iv=1,nh(is)
DO jv=1,nh(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
DO i=1,nwfc
qtemp(inl,i) = qtemp(inl,i) + qq_nt(iv,jv,is)*becwfc(jnl,i)
END DO
@ -474,7 +474,7 @@
use gvecw, only: ngw
use gvect, only: g, gstart
use electrons_base, only: n => nbsp, nx => nbspx
USE uspp, ONLY: nkb, qq_nt, ofsbeta
USE uspp, ONLY: nkb, qq_nt, indv_ijkb0
USE ldaU_cp, ONLY: Hubbard_U, Hubbard_l
USE ldaU_cp, ONLY: nwfcU
use cell_base, ONLY: tpiba
@ -548,7 +548,7 @@
allocate ( auxwfc(nwfcU,nh(alpha_s)) )
!
do iv=1,nh(alpha_s)
inl=ofsbeta(alpha_a) + iv
inl=indv_ijkb0(alpha_a) + iv
do m=1,nwfcU
auxwfc(m,iv) = becwfc(inl,m)
end do
@ -559,7 +559,7 @@
auxwfc, nwfcU, qq_nt(1,1,alpha_s), nh(alpha_s), &
0.0_DP, wfcbeta, nwfcU )
do iv=1,nh(alpha_s)
inl=ofsbeta(alpha_a) + iv
inl=indv_ijkb0(alpha_a) + iv
do m=1,nwfcU
auxwfc(m,iv) = wdb(inl,m,ipol)
end do
@ -574,7 +574,7 @@
allocate ( betapsi(nh(alpha_s),nb_s:nb_e) )
allocate ( dbetapsi(nh(alpha_s),nb_s:nb_e) )
do iv=1,nh(alpha_s)
inl=ofsbeta(alpha_a) + iv
inl=indv_ijkb0(alpha_a) + iv
do i=nb_s,nb_e
betapsi (iv,i)=bp(inl,i)
dbetapsi(iv,i)=dbp(inl,i,ipol)

40
CPV/src/nl_base.f90
View File

@ -93,7 +93,7 @@
USE mp_global, ONLY : nproc_bgrp, intra_bgrp_comm
USE ions_base, only : nat, nsp, ityp
USE gvecw, only : ngw
USE uspp, only : nkb, nhtol, beta, ofsbeta
USE uspp, only : nkb, nhtol, beta, indv_ijkb0
USE uspp_param, only : nh, upf, nhm
USE gvect, ONLY : gstart
!
@ -157,7 +157,7 @@
IF( pptype == 1 .AND. upf(is)%tvanp ) CYCLE
DO ia = 1, nat
IF( ityp(ia) == is ) THEN
inl = ofsbeta(ia)
inl = indv_ijkb0(ia)
do iv = 1, nh( is )
becp(inl+iv,:) = becps( inl+iv, : )
end do
@ -332,7 +332,7 @@
!
use kinds, only : DP
use uspp_param, only : nh, upf
use uspp, only : dvan, ofsbeta
use uspp, only : dvan, indv_ijkb0
use electrons_base, only : nbsp_bgrp, nspin, ispin_bgrp, f_bgrp, nbspx_bgrp
use ions_base, only : nsp, nat, ityp
!
@ -353,12 +353,12 @@
ennl_t = 0.d0
!
!$omp parallel num_threads(min(4,omp_get_num_threads())) default(none) &
!$omp shared(nat,ityp,ofsbeta,nh,nbsp_bgrp,ispin_bgrp,f_bgrp,bec_bgrp,rhovan,dvan,nspin,ennl_t) &
!$omp shared(nat,ityp,indv_ijkb0,nh,nbsp_bgrp,ispin_bgrp,f_bgrp,bec_bgrp,rhovan,dvan,nspin,ennl_t) &
!$omp private(ia,is,indv,iv,inl,jv,ijv,jnl,sums,iss,i,sumt)
!$omp do reduction(+:ennl_t)
do ia = 1, nat
is = ityp(ia)
indv = ofsbeta(ia)
indv = indv_ijkb0(ia)
do iv = 1, nh(is)
inl = indv + iv
do jv = iv, nh(is)
@ -397,7 +397,7 @@
!
use kinds, only : DP
use uspp_param, only : nh
use uspp, only : ofsbeta
use uspp, only : indv_ijkb0
use electrons_base, only : ispin, f
use ions_base, only : nat, ityp
!
@ -420,8 +420,8 @@
do iv = 1, nh(is)
do jv = iv, nh(is)
ijv = (jv-1)*jv/2 + iv
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
rhovan( ijv, ia, iss ) = f(iwf) * bec(inl,iwf) * bec(jnl,iwf)
end do
end do
@ -469,7 +469,7 @@ SUBROUTINE dbeta_eigr_x( dbeigr, eigr )
!
USE kinds, ONLY : DP
use ions_base, only : nat, ityp
use uspp, only : nhtol, nkb, dbeta, ofsbeta
use uspp, only : nhtol, nkb, dbeta, indv_ijkb0
use uspp_param, only : nh, nhm
use gvect, only : gstart
use gvecw, only : ngw
@ -500,7 +500,7 @@ SUBROUTINE dbeta_eigr_x( dbeigr, eigr )
do i=1,3
do ia = 1, nat
is = ityp(ia)
inl = ofsbeta(ia)
inl = indv_ijkb0(ia)
do iv=1,nh(is)
l=nhtol(iv,is)
! q = 0 component (with weight 1.0)
@ -536,7 +536,7 @@ SUBROUTINE caldbec_bgrp_x( eigr, c_bgrp, dbec, idesc )
use mp, only : mp_sum
use mp_global, only : nproc_bgrp, intra_bgrp_comm, inter_bgrp_comm, nbgrp
use ions_base, only : nat, ityp
use uspp, only : nhtol, nkb, dbeta, ofsbeta
use uspp, only : nhtol, nkb, dbeta, indv_ijkb0
use uspp_param, only : nh, nhm
use gvect, only : gstart
use gvecw, only : ngw
@ -580,7 +580,7 @@ SUBROUTINE caldbec_bgrp_x( eigr, c_bgrp, dbec, idesc )
end if
do ia = 1, nat
is = ityp(ia)
inl = ofsbeta(ia)
inl = indv_ijkb0(ia)
do iss=1,nspin
IF( idesc( LAX_DESC_ACTIVE_NODE, iss ) > 0 ) THEN
nr = idesc( LAX_DESC_NR, iss )
@ -621,7 +621,7 @@ subroutine dennl_x( bec_bgrp, dbec, drhovan, denl, idesc )
!
USE kinds, ONLY : DP
use uspp_param, only : nh
use uspp, only : nkb, dvan, deeq, ofsbeta
use uspp, only : nkb, dvan, deeq, indv_ijkb0
use ions_base, only : nat, ityp
use cell_base, only : h
use io_global, only : stdout
@ -650,7 +650,7 @@ subroutine dennl_x( bec_bgrp, dbec, drhovan, denl, idesc )
drhovan=0.0d0
!$omp parallel default(none) &
!$omp shared(nat,ityp,ofsbeta,nh,nbsp_bgrp,ispin_bgrp,f_bgrp,bec_bgrp,drhovan,dvan,nspin,denl) &
!$omp shared(nat,ityp,indv_ijkb0,nh,nbsp_bgrp,ispin_bgrp,f_bgrp,bec_bgrp,drhovan,dvan,nspin,denl) &
!$omp shared(idesc,iupdwn,nupdwn,ibgrp_g2l,nrcx,dbec) &
!$omp private(ia,is,iv,inl,jv,ijv,jnl,dsums,iss,i,dsum,ii,ir,k,j,nr,istart,nss,ibgrp)
!$omp do reduction(+:denl)
@ -659,8 +659,8 @@ subroutine dennl_x( bec_bgrp, dbec, drhovan, denl, idesc )
do iv=1,nh(is)
do jv=iv,nh(is)
ijv = (jv-1)*jv/2 + iv
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
dsums=0.d0
do iss=1,nspin
IF( ( idesc( LAX_DESC_ACTIVE_NODE, iss ) > 0 ) .AND. &
@ -723,7 +723,7 @@ subroutine nlfq_bgrp_x( c_bgrp, betae, bec_bgrp, becdr_bgrp, fion )
! contribution to fion due to nonlocal part
!
USE kinds, ONLY : DP
use uspp, only : nkb, dvan, deeq, ofsbeta
use uspp, only : nkb, dvan, deeq, indv_ijkb0
use uspp_param, only : nhm, nh
use ions_base, only : nax, nat, ityp
use electrons_base, only : nbsp_bgrp, f_bgrp, nbspx_bgrp, ispin_bgrp
@ -766,7 +766,7 @@ subroutine nlfq_bgrp_x( c_bgrp, betae, bec_bgrp, becdr_bgrp, fion )
fion_loc = 0.0d0
!
!$omp parallel default(none), &
!$omp shared(becdr_bgrp,bec_bgrp,fion_loc,f_bgrp,deeq,dvan,nbsp_bgrp,ofsbeta,nh, &
!$omp shared(becdr_bgrp,bec_bgrp,fion_loc,f_bgrp,deeq,dvan,nbsp_bgrp,indv_ijkb0,nh, &
!$omp nat,nhm,nbspx_bgrp,ispin_bgrp,nproc_bgrp,me_bgrp,ityp), &
!$omp private(tmpbec,tmpdr,is,ia,iv,jv,k,inl,jnl,temp,i,mytid,ntids,sum_tmpdr)
@ -792,7 +792,7 @@ subroutine nlfq_bgrp_x( c_bgrp, betae, bec_bgrp, becdr_bgrp, fion )
#endif
tmpbec = 0.d0
do jv=1,nh(is)
jnl = ofsbeta(ia) + jv
jnl = indv_ijkb0(ia) + jv
do iv=1,nh(is)
do i = 1, nbsp_bgrp
temp = dvan(iv,jv,is) + deeq(jv,iv,ia,ispin_bgrp( i ) )
@ -802,7 +802,7 @@ subroutine nlfq_bgrp_x( c_bgrp, betae, bec_bgrp, becdr_bgrp, fion )
end do
do iv = 1, nh(is)
inl = ofsbeta(ia) + iv
inl = indv_ijkb0(ia) + iv
do i = 1, nbsp_bgrp
tmpdr(i,iv) = f_bgrp( i ) * becdr_bgrp( inl, i, k )
end do

8
CPV/src/ortho.f90
View File

@ -377,7 +377,7 @@ CONTAINS
!
SUBROUTINE compute_qs_times_betas( bephi, bec_row, qbephi, qbecp, idesc )
USE uspp, ONLY: nkb, qq_nt, qq_nt_d, ofsbeta, nkbus
USE uspp, ONLY: nkb, qq_nt, qq_nt_d, indv_ijkb0, nkbus
USE uspp_param, ONLY: nh, upf
USE electrons_base, ONLY: nspin, nbsp_bgrp, iupdwn_bgrp, nupdwn_bgrp, nbsp, nupdwn, iupdwn
USE ions_base, ONLY: na, nat, nsp, ityp
@ -428,7 +428,7 @@ CONTAINS
DO ia = 1, nat
is = ityp(ia)
IF( upf(is)%tvanp ) THEN
indv = ofsbeta(ia)
indv = indv_ijkb0(ia)
nhs = nh(is)
#if defined (__CUDA)
CALL DGEMMDRV('N', 'N', nhs, nc, nhs, 1.0d0, qq_nt_d(1,1,is), SIZE(qq_nt_d,1), &
@ -462,7 +462,7 @@ CONTAINS
END SUBROUTINE compute_qs_times_betas
SUBROUTINE keep_only_us(wrk)
USE uspp, ONLY: ofsbeta
USE uspp, ONLY: indv_ijkb0
USE uspp_param, ONLY: nh, upf
USE ions_base, ONLY: na, nat, nsp, ityp
#if defined (__CUDA)
@ -473,7 +473,7 @@ CONTAINS
INTEGER :: ia, is, inl, nhs, iv
DO ia = 1, nat
is = ityp(ia)
inl = ofsbeta(ia)
inl = indv_ijkb0(ia)
nhs = nh(is)
IF( .NOT. upf(is)%tvanp ) THEN
!$cuf kernel do (1)

6
CPV/src/ortho_base.f90
View File

@ -1166,7 +1166,7 @@ CONTAINS
USE io_global, ONLY: stdout
USE mp_bands, ONLY: intra_bgrp_comm, inter_bgrp_comm
USE uspp_param, ONLY: nh, upf
USE uspp, ONLY: nkb, nkbus, qq_nt, ofsbeta
USE uspp, ONLY: nkb, nkbus, qq_nt, indv_ijkb0
USE gvecw, ONLY: ngw
USE electrons_base, ONLY: nbsp_bgrp, nbsp
USE constants, ONLY: pi, fpi
@ -1207,11 +1207,11 @@ CONTAINS
qtemp (:,:) = 0.d0
!$omp parallel do default(none) &
!$omp shared(nat,ityp,upf,nh,ofsbeta,qq_nt,qtemp,bec_bgrp,nbsp_bgrp) &
!$omp shared(nat,ityp,upf,nh,indv_ijkb0,qq_nt,qtemp,bec_bgrp,nbsp_bgrp) &
!$omp private(ia,is,iv,inl,jv,jnl,qqf,i,indv)
DO ia = 1, nat
is = ityp(ia)
indv = ofsbeta(ia)
indv = indv_ijkb0(ia)
IF( upf(is)%tvanp ) THEN
DO iv=1,nh(is)
inl = indv + iv

8
CPV/src/pseudopot_sub.f90
View File

@ -69,7 +69,7 @@
nhtolm, &!
indv, &!
ijtoh, &!
ofsbeta !
indv_ijkb0 !
IMPLICIT NONE
@ -107,13 +107,13 @@
if( allocated( indv ) ) deallocate( indv )
if( allocated( nhtolm ) ) deallocate( nhtolm )
if( allocated( ijtoh ) ) deallocate( ijtoh )
if( allocated( ofsbeta ) ) deallocate( ofsbeta )
if( allocated( indv_ijkb0 ) ) deallocate( indv_ijkb0 )
!
allocate(nhtol(nhm,nsp))
allocate(indv (nhm,nsp))
allocate(nhtolm(nhm,nsp))
allocate(ijtoh(nhm,nhm,nsp))
allocate(ofsbeta(nat))
allocate(indv_ijkb0(nat))
! ------------------------------------------------------------------
! definition of indices nhtol, indv, nhtolm
@ -150,7 +150,7 @@
! atom ia in the global list of beta functions
do ia = 1,nat
IF ( ityp(ia) == is ) THEN
ofsbeta(ia) = ijkb0
indv_ijkb0(ia) = ijkb0
ijkb0 = ijkb0 + nh(is)
END IF
end do

6
CPV/src/qmatrixd.f90
View File

@ -26,7 +26,7 @@ subroutine qmatrixd(c0, bec0,ctable, gqq, qmat, detq, ipol)
use ions_base, only : nax, nsp, na, nat, ityp
use gvect, only: gstart
use uspp_param, only: nh, nhm, upf
use uspp, only : nkb, ofsbeta
use uspp, only : nkb, indv_ijkb0
use electrons_base, only: nx => nbspx, n => nbsp, ispin
use mp, only: mp_sum, mp_alltoall
use mp_global, only: intra_bgrp_comm, nproc_bgrp
@ -187,8 +187,8 @@ subroutine qmatrixd(c0, bec0,ctable, gqq, qmat, detq, ipol)
IF( upf(is)%tvanp ) THEN !loop on vanderbilt species
do iv=1,nh(is)!loop on projectors
do jv=1,nh(is)
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
sca=sca+gqq(iv,jv,ia,is)*bec0(inl,ix)*bec0(jnl,jx)
enddo
enddo

2
CPV/src/qqberry.f90
View File

@ -16,7 +16,7 @@ subroutine qqberry2( gqq,gqqm, ipol)
use kinds, only: dp
use uspp_param, only: upf, lmaxq, nbetam, nh, nhm
use uspp, only: indv, lpx, lpl, ap,nhtolm, nkbus, ofsbeta
use uspp, only: indv, lpx, lpl, ap,nhtolm, nkbus, indv_ijkb0
use atom, only: rgrid
use core
use gvecw, only: ngw

6
CPV/src/spinsq.f90
View File

@ -34,7 +34,7 @@
USE gvecw, ONLY: ngw
USE gvect, ONLY: gstart
USE cell_base, ONLY: omega
USE uspp, ONLY: nkb, nkbus, qq_nt, ofsbeta
USE uspp, ONLY: nkb, nkbus, qq_nt, indv_ijkb0
USE uspp_param, ONLY: nh, upf
USE ions_base, ONLY: na, nat, ityp
!
@ -120,8 +120,8 @@
DO iv=1,nh(is)
DO jv=1,nh(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
inl = ofsbeta(ia) + iv
jnl = ofsbeta(ia) + jv
inl = indv_ijkb0(ia) + iv
jnl = indv_ijkb0(ia) + jv
overlap(i,j) = overlap(i,j) + qq_nt(iv,jv,is)*bec(inl,i)*bec(jnl,jj)
ENDIF
END DO

6
CPV/src/wave.f90
View File

@ -151,7 +151,7 @@
!=----------------------------------------------------------------------------=!
SUBROUTINE protate_x ( c0, bec, c0rot, becrot, ngwl, nss, noff, lambda, nrl, &
ityp, nat, ofsbeta, nh, np_rot, me_rot, comm_rot )
ityp, nat, indv_ijkb0, nh, np_rot, me_rot, comm_rot )
!=----------------------------------------------------------------------------=!
! this routine rotates the wave functions using the matrix lambda
@ -182,7 +182,7 @@
! ... declare subroutine arguments
INTEGER, INTENT(IN) :: ngwl, nss, nrl, noff
INTEGER, INTENT(IN) :: ityp(:), nat, ofsbeta(:), nh(:)
INTEGER, INTENT(IN) :: ityp(:), nat, indv_ijkb0(:), nh(:)
INTEGER, INTENT(IN) :: np_rot, me_rot, comm_rot
COMPLEX(DP), INTENT(IN) :: c0(:,:)
COMPLEX(DP), INTENT(OUT) :: c0rot(:,:)
@ -233,7 +233,7 @@
do ia=1,nat
is=ityp(ia)
do jv=1,nh(is)
jnl = ofsbeta(ia) + jv
jnl = indv_ijkb0(ia) + jv
do i = 1, nss
becrot(jnl,i+noff-1) = becrot(jnl,i+noff-1)+ uu(jl, i) * bec( jnl, j+noff-1 )
end do

6
CPV/src/wf.f90
View File

@ -24,7 +24,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
USE kinds, ONLY : DP
USE constants, ONLY : pi, tpi
USE ions_base, ONLY : nsp, na, nax, nat, ityp
USE uspp, ONLY : ofsbeta, nkbus
USE uspp, ONLY : indv_ijkb0, nkbus
USE uspp_param, ONLY : upf
USE cell_base, ONLY : omega, at, alat, h, ainv
USE electrons_base, ONLY : nbspx, nbsp, nupdwn, iupdwn, nspin
@ -319,7 +319,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
is = ityp(ia)
IF( upf(is)%tvanp ) THEN
DO iv = 1, nh(is)
inl = ofsbeta(ia) + iv
inl = indv_ijkb0(ia) + iv
jv = iv
ijv=(jv-1)*jv/2 + iv
fg1 = eigrb(1:ngb,ia)*qgb(1:ngb,ijv,is)
@ -361,7 +361,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
END DO
END IF
DO jv = iv+1, nh(is)
jnl = ofsbeta(ia) + jv
jnl = indv_ijkb0(ia) + jv
ijv = (jv-1)*jv/2 + iv
fg1 = eigrb(1:ngb,ia)*qgb(1:ngb,ijv,is)
CALL fft_oned2box( qv, fg1 )

18
GWW/pw4gww/realus.f90
View File

@ -19,7 +19,7 @@
USE fft_base, ONLY : dfftp
USE gvect, ONLY : ngm, gg, g
USE lsda_mod, ONLY : lsda, nspin, current_spin, isk
USE uspp, ONLY : okvan, becsum, nkb, ijtoh, ofsbeta
USE uspp, ONLY : okvan, becsum, nkb, ijtoh, indv_ijkb0
USE uspp_param, ONLY : upf, lmaxq, nh
USE wvfct, ONLY : wg
USE control_flags, ONLY : gamma_only
@ -74,11 +74,11 @@
!
DO ih = 1, nhnt
!
ikb = ofsbeta(ia) + ih
ikb = indv_ijkb0(ia) + ih
!
DO jh = ih, nhnt
!
jkb = ofsbeta(ia) + jh
jkb = indv_ijkb0(ia) + jh
!
DO ir = 1, mbia
!
@ -117,7 +117,7 @@
USE fft_base, ONLY : dfftp
USE gvect, ONLY : ngm, gg, g
USE lsda_mod, ONLY : lsda, nspin, current_spin, isk
USE uspp, ONLY : okvan, becsum, nkb, ijtoh, ofsbeta
USE uspp, ONLY : okvan, becsum, nkb, ijtoh, indv_ijkb0
USE uspp_param, ONLY : upf, lmaxq, nh
USE wvfct, ONLY : wg
USE control_flags, ONLY : gamma_only
@ -159,10 +159,10 @@
!
DO ih = 1, nhnt
!
ikb = ofsbeta(ia) + ih
ikb = indv_ijkb0(ia) + ih
DO jh = ih, nhnt
!
jkb = ofsbeta(ia) + jh
jkb = indv_ijkb0(ia) + jh
!
DO ir = 1, mbia
!
@ -199,7 +199,7 @@
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE gvect, ONLY : ngm, gg, g
USE lsda_mod, ONLY : lsda, nspin, current_spin, isk
USE uspp, ONLY : okvan, becsum, nkb, ofsbeta
USE uspp, ONLY : okvan, becsum, nkb, indv_ijkb0
USE uspp_param, ONLY : upf, lmaxq, nh, nhm
USE wvfct, ONLY : wg
USE control_flags, ONLY : gamma_only
@ -244,10 +244,10 @@
!
DO ih = 1, nhnt
!
ikb = ofsbeta(ia) + ih
ikb = indv_ijkb0(ia) + ih
DO jh = ih, nhnt
!
jkb = ofsbeta(ia) + jh
jkb = indv_ijkb0(ia) + jh
!
sca = sca + qq_op(ih,jh,ia) * becp_iw(ikb)*becp_jw(jkb)
!

4
GWW/simple/khamiltonian.f90
View File

@ -23,7 +23,7 @@ subroutine khamiltonian
USE cell_base, ONLY : omega
USE ions_base, ONLY: nat, ntyp => nsp, ityp
USE uspp_param, ONLY: nh, nhm
USE uspp, ONLY: nkb, deeq, ofsbeta, deeq_nc
USE uspp, ONLY: nkb, deeq, indv_ijkb0, deeq_nc
USE lsda_mod, ONLY : nspin
USE becmod, ONLY : bec_type, calbec, allocate_bec_type, deallocate_bec_type
USE wvfct, ONLY : npwx
@ -193,7 +193,7 @@ subroutine khamiltonian
write(iun) npol
write(iun) ityp(1:nat)
write(iun) nh(1:ntyp)
write(iun) ofsbeta(1:nat)
write(iun) indv_ijkb0(1:nat)
write(iun) nkpoints
endif
!

8
GWW/simple_ip/diagonalization.f90
View File

@ -99,9 +99,9 @@ SUBROUTINE diagonalization(q,sh,input,eig,ik,kptns)
if ( sh%ityp(na) == nt ) then
do j=1,sh%ntot_e
do jh=1,sh%nh(nt)
jkb = sh%ofsbeta(na)+jh
jkb = sh%indv_ijkb0(na)+jh
do ih=1,sh%nh(nt)
ikb = sh%ofsbeta(na)+ih
ikb = sh%indv_ijkb0(na)+ih
!
csca_nc(ikb,1,j) = csca_nc(ikb,1,j) + &
sh%deeq_nc(ih,jh,na,1)*b_nc(jkb,1,j)+ &
@ -135,8 +135,8 @@ SUBROUTINE diagonalization(q,sh,input,eig,ik,kptns)
!
deeaux(1:sh%nh(nt),1:sh%nh(nt)) = sh%deeqc(1:sh%nh(nt),1:sh%nh(nt),na)
call ZGEMM('N','N', sh%nh(nt), sh%ntot_e, sh%nh(nt), (1.d0,0.d0), &
deeaux, sh%nh(nt), b_c(sh%ofsbeta(na)+1,1), sh%nkb, &
(0.d0, 0.d0), csca_mat(sh%ofsbeta(na)+1,1), sh%nkb )
deeaux, sh%nh(nt), b_c(sh%indv_ijkb0(na)+1,1), sh%nkb, &
(0.d0, 0.d0), csca_mat(sh%indv_ijkb0(na)+1,1), sh%nkb )
!
endif
enddo

14
GWW/simple_ip/simple_ip_objects.f90
View File

@ -45,7 +45,7 @@ MODULE simple_ip_objects
INTEGER, DIMENSION(3) :: nkpoints ! smooth k-points grid on which H(k) is calculated
INTEGER, DIMENSION(:), POINTER :: ityp ! (nat)
INTEGER, DIMENSION(:), POINTER :: nh ! (ntyp)
INTEGER, DIMENSION(:), POINTER :: ofsbeta ! (nat)
INTEGER, DIMENSION(:), POINTER :: indv_ijkb0 ! (nat)
REAL(kind=8) :: alat, nelec, omega ! lattice paramater, number of electrons, volume prim. cell
REAL(kind=8) :: bg(3,3) ! reciprocal basis vectors
REAL(kind=8) :: at(3,3) ! direct basis vectors
@ -113,7 +113,7 @@ MODULE simple_ip_objects
TYPE(shirley) :: element
nullify(element%ityp)
nullify(element%nh)
nullify(element%ofsbeta)
nullify(element%indv_ijkb0)
nullify(element%h0)
nullify(element%h1)
nullify(element%Vloc)
@ -132,8 +132,8 @@ MODULE simple_ip_objects
nullify(element%ityp)
if(associated(element%nh)) deallocate(element%nh)
nullify(element%nh)
if(associated(element%ofsbeta)) deallocate(element%ofsbeta)
nullify(element%ofsbeta)
if(associated(element%indv_ijkb0)) deallocate(element%indv_ijkb0)
nullify(element%indv_ijkb0)
if(associated(element%h0)) deallocate(element%h0)
nullify(element%h0)
if(associated(element%h1)) deallocate(element%h1)
@ -226,16 +226,16 @@ MODULE simple_ip_objects
call mp_bcast(sh%npol,ionode_id,world_comm)
allocate(sh%ityp(sh%nat), sh%nh(sh%ntyp), sh%ofsbeta(sh%nat))
allocate(sh%ityp(sh%nat), sh%nh(sh%ntyp), sh%indv_ijkb0(sh%nat))
if(ionode) then
read(iun) sh%ityp(1:sh%nat)
read(iun) sh%nh(1:sh%ntyp)
read(iun) sh%ofsbeta(1:sh%nat)
read(iun) sh%indv_ijkb0(1:sh%nat)
read(iun) sh%nkpoints
endif
call mp_bcast(sh%ityp,ionode_id,world_comm)
call mp_bcast(sh%nh,ionode_id,world_comm)
call mp_bcast(sh%ofsbeta,ionode_id,world_comm)
call mp_bcast(sh%indv_ijkb0,ionode_id,world_comm)
call mp_bcast(sh%nkpoints,ionode_id,world_comm)
nk = (sh%nkpoints(1))*(sh%nkpoints(2))*(sh%nkpoints(3))

3
HP/src/hp_close_q.f90
View File

@ -15,10 +15,8 @@ SUBROUTINE hp_close_q ( flag )
! or during execution with flag=.FALSE. (does not remove 'recover')
!
USE buffers, ONLY : close_buffer
USE io_files, ONLY : iunhub
USE units_lr, ONLY : iuwfc, iuatswfc
USE ldaU_hp, ONLY : iudwfc, iudvwfc
USE control_lr, ONLY : lgamma
!
IMPLICIT NONE
!
@ -36,7 +34,6 @@ SUBROUTINE hp_close_q ( flag )
ENDIF
!
CALL close_buffer(iuatswfc,'delete')
IF (lgamma) CALL close_buffer(iunhub,'delete')
!
RETURN
!

12
HP/src/hp_openfil_q.f90
View File

@ -12,9 +12,10 @@ SUBROUTINE hp_openfil_q()
!
! This subroutine opens all necessary files necessary.
!
USE io_files, ONLY : prefix, tmp_dir, iunhub, nwordwfcU
USE io_files, ONLY : tmp_dir, nwordwfcU
USE control_flags, ONLY : io_level
USE wvfct, ONLY : nbnd, npwx
USE io_files, ONLY : prefix
USE noncollin_module, ONLY : npol
USE buffers, ONLY : open_buffer
USE qpoint, ONLY : nksq
@ -68,15 +69,6 @@ SUBROUTINE hp_openfil_q()
nwordwfcU = npwx * nwfcU * npol
CALL open_buffer (iuatswfc, 'satwfc', nwordwfcU, io_level, exst_mem, exst, tmp_dir)
!
IF (lgamma) THEN
!
! If q = Gamma, open unit iunhub which contain S*phi at k.
! Unit iunhub is used in commutator_Vhubx_psi.f90.
!
CALL open_buffer(iunhub, 'hub', nwordwfcU, io_level, exst_mem, exst, tmp_dir)
!
ENDIF
!
RETURN
!
END SUBROUTINE hp_openfil_q

1
HP/src/make.depend
View File

@ -37,7 +37,6 @@ hp_check_type.o : ../../PW/src/symm_base.o
hp_check_type.o : hpcom.o
hp_clean_q.o : ../../LR_Modules/lrcom.o
hp_close_q.o : ../../LR_Modules/lrcom.o
hp_close_q.o : ../../Modules/io_files.o
hp_close_q.o : ../../PW/src/buffers.o
hp_close_q.o : hpcom.o
hp_dealloc_1.o : ../../LR_Modules/lrcom.o

3
LR_Modules/CMakeLists.txt
View File

@ -10,6 +10,8 @@ set(sources
cgsolve_all.f90
cg_psi.f90
ch_psi_all.f90
commutator_Hx_psi.f90
commutator_Vhubx_psi.f90
Coul_cut_2D_ph.f90
check_q_points_sym.f90
dfpt_tetra_mod.f90
@ -24,6 +26,7 @@ set(sources
dv_rVV10.f90
newdq.f90
orthogonalize.f90
setup_offset_beta.f90
setup_nscf.f90
set_dbecsum_nc.f90
set_int3_nc.f90

3
LR_Modules/Makefile
View File

@ -21,6 +21,8 @@ cg_psi.o \
ccg_psi.o \
ch_psi_all.o \
ch_psi_all_complex.o \
commutator_Hx_psi.o \
commutator_Vhubx_psi.o \
Coul_cut_2D_ph.o \
check_q_points_sym.o \
dfpt_tetra_mod.o \
@ -38,6 +40,7 @@ compute_intq.o \
set_intq_nc.o \
lr_sym_mod.o \
orthogonalize.o \
setup_offset_beta.o \
setup_nscf.o \
set_dbecsum_nc.o \
set_int3_nc.o \

2
PW/src/commutator_Hx_psi.f90 → LR_Modules/commutator_Hx_psi.f90
View File

@ -230,7 +230,7 @@ subroutine commutator_Hx_psi (ik, nbnd_occ, becp1, becp2, ipol, dpsi)
! Compute the commutator between the non-local Hubbard potential
! and the position operator
!
IF (lda_plus_u) CALL commutator_Vhubx_psi(ik, ipol, nbnd_occ, dpsi)
IF (lda_plus_u) CALL commutator_Vhubx_psi(ik, ipol)
!
111 continue
!

220
PW/src/commutator_Vhubx_psi.f90 → LR_Modules/commutator_Vhubx_psi.f90
View File

@ -7,51 +7,48 @@
!
!
!-----------------------------------------------------------------------
SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
SUBROUTINE commutator_Vhubx_psi(ik, ipol)
!-----------------------------------------------------------------------
!
! This routine computes the commutator between the non-local
! Hubbard potential and the position operator, applied to psi
! of the current k point, i.e. [V_hub,r]|psi_nk> .
! of the current k point, i.e. [V_hub,r]|psi_nk> .
! The result is added to dpsi.
!
! Some insights about the formulas here can be found e.g.
! in I. Timrov's PhD thesis, Sec. 6.1.3,
! in I. Timrov's PhD thesis, Sec. 6.1.3,
! https://pastel.archives-ouvertes.fr/pastel-00823758
!
! Written by A. Floris
! Modified by I. Timrov (01.10.2018)
!
USE kinds, ONLY : DP
USE io_files, ONLY : iunhub, iunhub_noS, nwordwfcU
USE io_files, ONLY : nwordwfcU
USE wavefunctions, ONLY : evc
USE control_lr, ONLY : lgamma, nbnd_occ
USE wvfct, ONLY : npwx, nbnd
USE ions_base, ONLY : nat, ityp, ntyp => nsp
USE ldaU, ONLY : Hubbard_l, Hubbard_U, Hubbard_J0, &
is_hubbard, nwfcU, offsetU, oatwfc
USE uspp, ONLY : vkb, nkb, okvan
USE uspp_param, ONLY : nh, upf
is_hubbard, nwfcU, offsetU, oatwfc
USE uspp, ONLY : vkb, nkb, okvan
USE uspp_param, ONLY : nh, upf
USE eqv, ONLY : dpsi
USE lsda_mod, ONLY : lsda, current_spin, isk, nspin
USE klist, ONLY : xk, ngk, igk_k
USE klist, ONLY : xk, ngk, igk_k
USE cell_base, ONLY : tpiba, at
USE gvect, ONLY : g
USE gvect, ONLY : g
USE scf, ONLY : rho
USE mp, ONLY : mp_sum
USE mp_pools, ONLY : intra_pool_comm
USE units_lr, ONLY : iuatwfc, iuatswfc
USE buffers, ONLY : get_buffer
USE basis, ONLY : natomwfc
USE noncollin_module, ONLY : noncolin, npol
!
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: ik
!! k point index
INTEGER, INTENT(IN) :: ipol
!! polarization in crystal coordinates
INTEGER, INTENT(IN) :: nbnd_calc
!! Number of bands to calculate [V_hub, x_ipol]|psi_ik>
COMPLEX(DP), INTENT(OUT) :: dpsi(npwx*npol, nbnd)
!! Output wavefunction where [V_hub, x_ipol]|psi_ik> is added
INTEGER, INTENT(IN) :: ik, ipol
! k point index
! polarization (crystal units)
!
REAL(DP), PARAMETER :: eps = 1.0d-8
INTEGER :: na, n ,l, nt, nah, ikb , m, m1, m2, ibnd, ib, ig, jkb, i, &
@ -61,7 +58,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
COMPLEX(DP), ALLOCATABLE :: dkwfcbessel(:,:), dkwfcylmr(:,:), dkwfcatomk(:,:), &
dpqq26(:,:), dpqq38(:,:), dpqq47(:,:), dkvkbbessel(:,:), &
dkvkbylmr(:,:), dkvkb(:,:), aux_1234(:), termi(:,:), trm(:,:), &
wfcatomk(:,:), swfcatomk(:,:), proj1(:,:), proj2(:,:), proj3(:,:)
wfcatomk(:,:), swfcatomk(:,:), proj1(:,:), proj2(:,:), proj3(:,:)
COMPLEX(DP), EXTERNAL :: zdotc
!
CALL start_clock( 'commutator_Vhubx_psi' )
@ -90,34 +87,34 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
ALLOCATE (gk(3,npw))
ALLOCATE (g2k(npw))
!
dpqq26 = (0.d0, 0.d0)
dpqq26 = (0.d0, 0.d0)
dpqq38 = (0.d0, 0.d0)
dpqq47 = (0.d0, 0.d0)
dkwfcatomk = (0.d0, 0.d0)
dkwfcatomk = (0.d0, 0.d0)
dkvkb = (0.d0, 0.d0)
!
!
IF (lsda) THEN
current_spin = isk(ik)
if (nspin == 2) then
if (current_spin == 1) then
if (nspin.eq.2) then
if (current_spin.eq.1) then
op_spin = 2
else
op_spin = 1
endif
else
else
op_spin=1
endif
ENDIF
!
! Read the atomic orbitals \phi at k from file (unit iunhub_noS)
! Read the atomic orbitals \phi at k from file (unit iuatwfc)
!
CALL get_buffer (wfcatomk, nwordwfcU, iuatwfc, ik)
!
CALL get_buffer (wfcatomk, nwordwfcU, iunhub_noS, ik)
! Read S*\phi at k from file (unit iuatswfc)
!
! Read S*\phi at k from file (unit iunhub)
CALL get_buffer (swfcatomk, nwordwfcU, iuatswfc, ik)
!
CALL get_buffer (swfcatomk, nwordwfcU, iunhub, ik)
!
! Derivatives w.r.t. k of the atomic wfc
! Derivatives w.r.t. k of the atomic wfc
! \phi'_(k+G,I,m)_ipol> = exp^-i(k+G)*tau_I * d/dk_ipol[\phi_0(k+G,I,m)]
! where \phi_0(k+G,I,m) is the Fourier component of the atomic wfc localized in zero
!
@ -129,7 +126,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
DO ig = 1, npw
!
! The gk factor is necessary because we do not want the derivative of the Bessel functions
! w.r.t. the modulus (calculated in gen_at_dj.f90), but w.r.t.
! w.r.t. the modulus (calculated in gen_at_dj.f90), but w.r.t.
! the cartesian component and then to crystal component ipol
! gk_icart= d|k+G|/d(k+G)_icart
!
@ -143,7 +140,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
gk(:,ig) = gk(:,ig) / SQRT(g2k(ig))
ENDIF
!
! Derivative wrt crystal axis ipol
! Derivative wrt crystal axis ipol
! d|k+G|/d(k+G)_ipol = \sum_{icart} d|k+G|/d(k+G)_icart * at (icart,ipol)
! The derivative is done for all the atomic wfc and for each ig
!
@ -157,7 +154,7 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
+ dkwfcbessel(ig,offpm+m1) * &
( at (1, ipol) * gk (1, ig) + &
at (2, ipol) * gk (2, ig) + &
at (3, ipol) * gk (3, ig) )
at (3, ipol) * gk (3, ig) )
ENDDO
ENDIF
ENDDO
@ -196,19 +193,19 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
! Preliminary calculation of various scalar products
! The Hubbard terms
!
DO nah = 1, nat
DO nah = 1, nat
!
nt = ityp (nah)
nt = ityp (nah)
!
IF (is_hubbard(nt)) THEN
IF (is_hubbard(nt)) THEN
!
DO m = 1, 2 * Hubbard_l(nt) + 1
!
!
ihubst = offsetU(nah) + m
!
IF (okvan) THEN
IF (okvan) THEN
!
! vecqqproj for terms 2,3,4,6,7,8
! vecqqproj for terms 2,3,4,6,7,8
! term 6 is the cc of term 2 with m <=> m'
! the same holds for 3 and 8, 4 and 7
! Note: these are the notations from private notes of A. Floris
@ -216,24 +213,24 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
CALL vecqqproj (npw, vkb, vkb, dkwfcatomk(:,ihubst), dpqq26(:,ihubst))
CALL vecqqproj (npw, dkvkb, vkb, wfcatomk(:,ihubst), dpqq38(:,ihubst))
CALL vecqqproj (npw, vkb, dkvkb, wfcatomk(:,ihubst), dpqq47(:,ihubst))
!
DO ibnd = 1, nbnd_calc
!
DO ibnd = 1, nbnd_occ(ik)
proj3(ibnd,ihubst) = zdotc (npw, dpqq26(:,ihubst), 1, evc(:,ibnd), 1) + &
zdotc (npw, dpqq47(:,ihubst), 1, evc(:,ibnd), 1) + &
zdotc (npw, dpqq38(:,ihubst), 1, evc(:,ibnd), 1)
zdotc (npw, dpqq38(:,ihubst), 1, evc(:,ibnd), 1)
ENDDO
!
!
ENDIF
!
DO ibnd = 1, nbnd_calc
!
! Calculate proj (ihubst,ibnd) = < S_{k}\phi_(k,I,m)| psi(ibnd,ik) >
! at ihubst (i.e. I, m).
!
DO ibnd = 1, nbnd_occ(ik)
!
! Calculate proj (ihubst,ibnd) = < S_{k}\phi_(k,I,m)| psi(ibnd,ik) >
! at ihubst (i.e. I, m).
!
proj1(ibnd,ihubst) = zdotc (npw, swfcatomk(:,ihubst), 1, evc(:,ibnd), 1)
proj2(ibnd,ihubst) = zdotc (npw, dkwfcatomk(:,ihubst), 1, evc(:,ibnd), 1)
proj2(ibnd,ihubst) = zdotc (npw, dkwfcatomk(:,ihubst), 1, evc(:,ibnd), 1)
!
ENDDO
ENDDO
!
ENDDO
!
@ -241,108 +238,110 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
!
ENDDO
!
#if defined(__MPI)
CALL mp_sum(proj1, intra_pool_comm)
CALL mp_sum(proj2, intra_pool_comm)
CALL mp_sum(proj3, intra_pool_comm)
#endif
!
DO nah = 1, nat ! the Hubbard atom
DO nah = 1, nat ! the Hubbard atom
!
nt = ityp (nah)
nt = ityp (nah)
!
IF (is_hubbard(nt)) THEN
!
termi = (0.d0, 0.d0)
!
!
DO m1 = 1, 2*Hubbard_l(nt)+1
!
ihubst1 = offsetU(nah) + m1
aux_1234 = (0.d0, 0.d0)
!
ihubst1 = offsetU(nah) + m1
aux_1234 = (0.d0, 0.d0)
!
! term1 + term2 + term3 + term4
!
aux_1234 = dkwfcatomk(:,ihubst1)
!
aux_1234 = dkwfcatomk(:,ihubst1)
!
IF (okvan) THEN
aux_1234 = aux_1234 + dpqq26(:,ihubst1) &
+ dpqq38(:,ihubst1) &
+ dpqq47(:,ihubst1)
ENDIF
!
DO m2 = 1, 2 * Hubbard_l(nt) + 1
!
ihubst2 = offsetU(nah) + m2
+ dpqq47(:,ihubst1)
ENDIF
!
DO m2 = 1, 2 * Hubbard_l(nt) + 1
!
ihubst2 = offsetU(nah) + m2
!
trm = (0.d0, 0.d0)
!
!
nsaux = rho%ns(m1, m2, current_spin, nah)
!
DO ibnd = 1, nbnd_calc
DO ibnd = 1, nbnd_occ(ik)
trm(:,ibnd) = aux_1234(:) * proj1(ibnd,ihubst2) + & ! term_1234
swfcatomk(:,ihubst1) * proj2(ibnd,ihubst2) ! term 5
swfcatomk(:,ihubst1) * proj2(ibnd,ihubst2) ! term 5
ENDDO
!
IF (okvan) THEN
DO ibnd = 1, nbnd_calc
!
IF (okvan) THEN
DO ibnd = 1, nbnd_occ(ik)
trm(:,ibnd) = trm(:,ibnd) + swfcatomk(:,ihubst1) * &
proj3(ibnd,ihubst2) ! term_6+7+8
ENDDO
ENDIF
!
!
! termi (npwx,nbnd), trm (npwx,nbnd), summing for all bands and G vectors
!
DO ibnd = 1, nbnd_calc
DO ibnd = 1, nbnd_occ(ik)
IF (m1 == m2) termi(:,ibnd) = termi(:,ibnd) + 0.5d0 * trm(:,ibnd)
termi(:,ibnd) = termi(:,ibnd) - nsaux * trm(:,ibnd)
termi(:,ibnd) = termi(:,ibnd) - nsaux * trm(:,ibnd)
ENDDO
!
!
ENDDO
!
ENDDO
!
! We want to have -i d/dk
!
DO ibnd = 1, nbnd_calc
DO ibnd = 1, nbnd_occ(ik)
dpsi(:,ibnd) = dpsi(:,ibnd) + (0.d0,-1.d0) * termi(:,ibnd) * &
(Hubbard_U(nt) - Hubbard_J0(nt))
ENDDO
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The following is for the J0\=0 case
!
! The following is for the J0\=0 case
!
IF (nspin.EQ.2 .AND. Hubbard_J0(nt).NE.0.d0) THEN
!
termi = (0.d0, 0.d0)
!
DO m1 = 1, 2*Hubbard_l(nt)+1
!
DO m1 = 1, 2*Hubbard_l(nt)+1
!
ihubst1 = offsetU(nah) + m1
aux_1234 = (0.d0, 0.d0)
ihubst1 = offsetU(nah) + m1
aux_1234 = (0.d0, 0.d0)
!
! term1 + term2 + term3 + term4
!
aux_1234 = dkwfcatomk(:,ihubst1)
!
aux_1234 = dkwfcatomk(:,ihubst1)
!
IF (okvan) THEN
aux_1234 = aux_1234 + dpqq26(:,ihubst1) &
+ dpqq38(:,ihubst1) &
+ dpqq47(:,ihubst1)
ENDIF
+ dpqq47(:,ihubst1)
ENDIF
!
DO m2 = 1, 2*Hubbard_l(nt)+1
!
ihubst2 = offsetU(nah) + m2
DO m2 = 1, 2*Hubbard_l(nt)+1
!
ihubst2 = offsetU(nah) + m2
!
trm = (0.d0, 0.d0)
!
!
nsaux = rho%ns(m1, m2, op_spin, nah)
!
DO ibnd = 1, nbnd_calc
DO ibnd = 1, nbnd_occ(ik)
trm(:,ibnd) = aux_1234(:) * proj1(ibnd,ihubst2) + & ! term_1234
swfcatomk(:,ihubst1) * proj2(ibnd,ihubst2) ! term 5
swfcatomk(:,ihubst1) * proj2(ibnd,ihubst2) ! term 5
ENDDO
!
IF (okvan) THEN
DO ibnd = 1, nbnd_calc
!
IF (okvan) THEN
DO ibnd = 1, nbnd_occ(ik)
trm(:,ibnd) = trm(:,ibnd) + swfcatomk(:,ihubst1) &
* proj3(ibnd,ihubst2) ! term_6+7+8
ENDDO
@ -350,24 +349,24 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
!
! termi (npwx,nbnd), trm (npwx,nbnd), summing for all bands and G vectors
!
DO ibnd = 1, nbnd_calc
DO ibnd = 1, nbnd_occ(ik)
termi(:,ibnd) = termi(:,ibnd) + nsaux * trm(:,ibnd) ! sign change
ENDDO
!
!
ENDDO
!
ENDDO
!
! We want to have -i d/dk
!
DO ibnd = 1, nbnd_calc
DO ibnd = 1, nbnd_occ(ik)
dpsi(:,ibnd) = dpsi(:,ibnd) + (0.d0,-1.d0) * termi(:,ibnd) * Hubbard_J0(nt)
ENDDO
!
ENDIF
!
!
ENDIF
!
!
ENDDO
!
DEALLOCATE (proj1)
@ -390,26 +389,27 @@ SUBROUTINE commutator_Vhubx_psi(ik, ipol, nbnd_calc, dpsi)
DEALLOCATE (xyz)
DEALLOCATE (gk)
DEALLOCATE (g2k)
!
!
CALL stop_clock ('commutator_Vhubx_psi')
!
RETURN
!
!
END SUBROUTINE commutator_Vhubx_psi
SUBROUTINE vecqqproj (npw, vec1, vec2, vec3, dpqq)
!
! Calculate dpqq (ig) = \sum {na l1 l2} vec1(ig ,na,l1)
! Calculate dpqq (ig) = \sum {na l1 l2} vec1(ig ,na,l1)
! * qq(na, l1 ,l2) * < vec2 (na,l2) | vec3 >
!
USE kinds, ONLY : DP
USE uspp_param, ONLY : nh
USE ions_base, ONLY : nat, ityp
USE uspp, ONLY : qq_nt, nkb, ofsbeta
USE uspp, ONLY : qq_nt, nkb
USE wvfct, ONLY : npwx
USE mp, ONLY : mp_sum
USE mp_pools, ONLY : intra_pool_comm
!
USE control_lr, ONLY : ofsbeta
!
IMPLICIT NONE
!
! Index of the displaced atom
@ -426,14 +426,14 @@ SUBROUTINE vecqqproj (npw, vec1, vec2, vec3, dpqq)
COMPLEX(DP), ALLOCATABLE :: aux1(:)
COMPLEX(DP) :: projaux1vec3
COMPLEX(DP), EXTERNAL :: zdotc
!
!
dpqq = (0.d0, 0.d0)
!
ALLOCATE (aux1(npwx))
!
DO na = 1, nat
!
nt = ityp(na)
nt = ityp(na)
!
DO l1 = 1, nh(nt)
!
@ -450,8 +450,10 @@ SUBROUTINE vecqqproj (npw, vec1, vec2, vec3, dpqq)
!
projaux1vec3 = zdotc (npw, aux1, 1, vec3, 1)
!
#if defined(__MPI)
CALL mp_sum(projaux1vec3, intra_pool_comm)
!
#endif
!
! Summing on na and l1 for each ig
!
dpqq(:) = dpqq(:) + vec1(:,ibeta1) * projaux1vec3

7
LR_Modules/lr_orthoUwfc.f90
View File

@ -20,9 +20,6 @@ SUBROUTINE lr_orthoUwfc (lflag)
! write S(k)*phi(k) and S(k+q)*phi(k+q) to file with unit iuatswfc
! (note that this is not the same unit as iuatwfc).
!
! If lgamma = .TRUE., write phi(k) and S(k)*phi(k) also to iunhub and
! iunhub_noS. These are needed in commutator_Vhubx_psi.
!
! In the norm-conserving case, S(k)=1 and S(k+q)=1.
! Note: here the array wfcU is used as a workspace.
! Inspired by PW/src/orthoatwfc.f90
@ -30,7 +27,7 @@ SUBROUTINE lr_orthoUwfc (lflag)
! Written by I. Timrov (01.10.2018)
!
USE kinds, ONLY : DP
USE io_files, ONLY : iunhub, iunhub_noS, nwordwfcU
USE io_files, ONLY : nwordwfcU
USE basis, ONLY : natomwfc
USE klist, ONLY : xk, ngk, igk_k
USE wvfct, ONLY : npwx
@ -123,7 +120,6 @@ SUBROUTINE lr_orthoUwfc (lflag)
wfcU = (0.d0, 0.d0)
CALL copy_U_wfc (wfcatom, noncolin)
CALL save_buffer (wfcU, nwordwfcU, iuatwfc, ikk)
IF (lgamma) CALL save_buffer (wfcU, nwordwfcU, iunhub_noS, ik)
ENDIF
!
! Copy the result from (orthonormalized) swfcatom
@ -133,7 +129,6 @@ SUBROUTINE lr_orthoUwfc (lflag)
wfcU = (0.d0, 0.d0)
CALL copy_U_wfc (swfcatom, noncolin)
CALL save_buffer (wfcU, nwordwfcU, iuatswfc, ikk)
IF (lgamma) CALL save_buffer (wfcU, nwordwfcU, iunhub, ik)
!
IF (.NOT.lgamma) THEN
!

1
LR_Modules/lrcom.f90
View File

@ -60,6 +60,7 @@ MODULE control_lr
SAVE
!
INTEGER, ALLOCATABLE :: nbnd_occ(:) ! occupied bands in metals
INTEGER, ALLOCATABLE :: ofsbeta(:) ! for each atom gives the offset of beta functions
REAL(DP) :: alpha_pv ! the alpha value for shifting the bands
LOGICAL :: lgamma ! if .TRUE. this is a q=0 computation
LOGICAL :: lrpa ! if .TRUE. uses the Random Phace Approximation

30
LR_Modules/make.depend
View File

@ -125,6 +125,33 @@ ch_psi_all_complex.o : ../XClib/xc_lib.o
ch_psi_all_complex.o : ../upflib/uspp.o
ch_psi_all_complex.o : lrcom.o
check_q_points_sym.o : ../Modules/kind.o
commutator_Hx_psi.o : ../Modules/becmod.o
commutator_Hx_psi.o : ../Modules/cell_base.o
commutator_Hx_psi.o : ../Modules/control_flags.o
commutator_Hx_psi.o : ../Modules/io_global.o
commutator_Hx_psi.o : ../Modules/ions_base.o
commutator_Hx_psi.o : ../Modules/kind.o
commutator_Hx_psi.o : ../Modules/noncol.o
commutator_Hx_psi.o : ../Modules/recvec.o
commutator_Hx_psi.o : ../Modules/wavefunctions.o
commutator_Hx_psi.o : ../PW/src/ldaU.o
commutator_Hx_psi.o : ../PW/src/pwcom.o
commutator_Hx_psi.o : ../upflib/uspp.o
commutator_Vhubx_psi.o : ../Modules/cell_base.o
commutator_Vhubx_psi.o : ../Modules/io_files.o
commutator_Vhubx_psi.o : ../Modules/ions_base.o
commutator_Vhubx_psi.o : ../Modules/kind.o
commutator_Vhubx_psi.o : ../Modules/mp_pools.o
commutator_Vhubx_psi.o : ../Modules/recvec.o
commutator_Vhubx_psi.o : ../Modules/wavefunctions.o
commutator_Vhubx_psi.o : ../PW/src/atomic_wfc_mod.o
commutator_Vhubx_psi.o : ../PW/src/buffers.o
commutator_Vhubx_psi.o : ../PW/src/ldaU.o
commutator_Vhubx_psi.o : ../PW/src/pwcom.o
commutator_Vhubx_psi.o : ../PW/src/scf_mod.o
commutator_Vhubx_psi.o : ../UtilXlib/mp.o
commutator_Vhubx_psi.o : ../upflib/uspp.o
commutator_Vhubx_psi.o : lrcom.o
compute_intq.o : ../Modules/cell_base.o
compute_intq.o : ../Modules/ions_base.o
compute_intq.o : ../Modules/kind.o
@ -421,6 +448,9 @@ setup_nscf.o : ../PW/src/symm_base.o
setup_nscf.o : ../PW/src/tetra.o
setup_nscf.o : ../upflib/upf_ions.o
setup_nscf.o : lrcom.o
setup_offset_beta.o : ../Modules/ions_base.o
setup_offset_beta.o : ../upflib/uspp.o
setup_offset_beta.o : lrcom.o
sgam_lr.o : ../Modules/kind.o
smallgq.o : ../Modules/cell_base.o
smallgq.o : ../Modules/kind.o

39
LR_Modules/setup_offset_beta.f90 Normal file
View File

@ -0,0 +1,39 @@
!
! Copyright (C) 2001-2018 Quantum ESPRESSO
! This file is distributed under the terms
! GNU General Public License. See the file
! in the root directory of the present dis
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!------------------------------------------------------------
SUBROUTINE setup_offset_beta
!----------------------------------------------------------
!
! Calculate the offset of beta functions for each atom na.
! Ordering: first all betas for atoms of type 1,
! then all betas for atoms of type 2, and so on.
!
USE uspp_param, ONLY : nh
USE ions_base, ONLY : nat, ityp, ntyp => nsp
USE control_lr, ONLY : ofsbeta
!
IMPLICIT NONE
!
INTEGER :: na, iat, nt, jkb2, ih
!
jkb2 = 0
DO nt = 1, ntyp
DO na = 1, nat
IF ( ityp(na).EQ.nt ) THEN
ofsbeta(na) = jkb2
DO ih = 1, nh(nt)
jkb2 = jkb2 + 1
ENDDO
ENDIF
ENDDO
ENDDO
!
RETURN
!
END SUBROUTINE setup_offset_beta

2
Modules/io_files.f90
View File

@ -85,8 +85,6 @@ MODULE io_files
!! unit for saving mixing information
INTEGER :: iunwfc_exx = 16
!! unit with exx wavefunctions
INTEGER :: iunhub_noS = 17
!! unit for saving Hubbard-U atomic wfcs
!
INTEGER :: iunexit = 26
!! unit for a soft exit

3
PHonon/PH/allocate_phq.f90
View File

@ -42,7 +42,7 @@ subroutine allocate_phq
USE qpoint, ONLY : nksq, eigqts, xk_col
USE eqv, ONLY : dpsi, evq, vlocq, dmuxc, dvpsi
USE lr_symm_base, ONLY : rtau
USE control_lr, ONLY : lgamma
USE control_lr, ONLY : lgamma, ofsbeta
USE ldaU, ONLY : lda_plus_u, Hubbard_lmax, nwfcU
USE ldaU_ph, ONLY : dnsbare, dnsorth, dnsbare_all_modes, wfcatomk, &
dwfcatomk, sdwfcatomk, wfcatomkpq, dwfcatomkpq, &
@ -168,6 +168,7 @@ subroutine allocate_phq
ALLOCATE (dwfcatomk(npwx,nwfcU,3))
ALLOCATE (sdwfcatomk(npwx,nwfcU))
ALLOCATE (dvkb(npwx,nkb,3))
ALLOCATE (ofsbeta(nat))
!
ALLOCATE (dnsbare(ldim,ldim,nspin,nat,3,nat))
ALLOCATE (dnsbare_all_modes(ldim,ldim,nspin,nat,3*nat))

10
PHonon/PH/close_phq.f90
View File

@ -16,7 +16,6 @@ SUBROUTINE close_phq( flag )
USE mp_pools, ONLY : me_pool, root_pool
USE paw_variables, ONLY : okpaw
USE io_global, ONLY : ionode, stdout
USE io_files, ONLY : iunhub, iunhub_noS
USE buffers, ONLY : close_buffer
USE uspp, ONLY : okvan
USE units_ph, ONLY : iudwf, iubar, iudrhous, iuebar, iudrho, &
@ -29,7 +28,6 @@ SUBROUTINE close_phq( flag )
USE ramanm, ONLY : lraman, elop, iuchf, iud2w, iuba2
USE el_phon, ONLY : elph_mat,iunwfcwann
USE ldaU, ONLY : lda_plus_u
USE control_lr, ONLY : lgamma
USE dvscf_interpolate, ONLY : ldvscf_interpolate, dvscf_interpol_close
USE ahc, ONLY : elph_ahc
!
@ -109,13 +107,9 @@ SUBROUTINE close_phq( flag )
!
! DFPT+U
IF (lda_plus_u) THEN
CALL close_buffer(iuatwfc, 'delete')
CALL close_buffer(iuatswfc, 'delete')
CALL close_buffer(iuatwfc,'delete')
CALL close_buffer(iuatswfc,'delete')
CLOSE( UNIT = iundnsscf, STATUS = 'KEEP' )
IF (lgamma) THEN
CALL close_buffer(iunhub, 'delete')
CALL close_buffer(iunhub_noS, 'delete')
ENDIF
ENDIF
!
! dVscf Fourier interpolation

12
PHonon/PH/d2nsq_bare.f90
View File

@ -22,10 +22,11 @@ SUBROUTINE doubleprojqq (na, vec1, vec2, vec3, vec4, npw1, npw2, dpqq)
USE kinds, ONLY : DP
USE uspp_param, ONLY : nh
USE ions_base, ONLY : ityp
USE uspp, ONLY : qq_nt, ofsbeta
USE uspp, ONLY : qq_nt
USE wvfct, ONLY : npwx, nbnd
USE mp_pools, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
USE control_lr, ONLY : ofsbeta
!
IMPLICIT NONE
!
@ -111,10 +112,11 @@ SUBROUTINE doubleprojqq2 (na, proj, vec3, vec4, npw2, dpqq)
USE kinds, ONLY : DP
USE uspp_param, ONLY : nh
USE ions_base, ONLY : ityp
USE uspp, ONLY : qq_nt, ofsbeta
USE uspp, ONLY : qq_nt
USE wvfct, ONLY : npwx, nbnd
USE mp_pools, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
USE control_lr, ONLY : ofsbeta
!
IMPLICIT NONE
!
@ -314,10 +316,11 @@ SUBROUTINE term_one (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, &
!--------------------------------------------------------------------
!
USE kinds, ONLY : DP
USE uspp, ONLY : nkb, okvan, ofsbeta
USE uspp, ONLY : nkb, okvan
USE wvfct, ONLY : npwx, nbnd, wg
USE uspp_param, ONLY : nh
USE ions_base, ONLY : ityp
USE control_lr, ONLY : ofsbeta
USE ldaU_ph, ONLY : proj1, projpb, projpdb
USE klist, ONLY : ngk, igk_k
USE qpoint, ONLY : ikks, ikqs
@ -503,10 +506,11 @@ SUBROUTINE term_one_diag (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, &
!------------------------------------------------------------------------
!
USE kinds, ONLY : DP
USE uspp, ONLY : nkb, okvan, ofsbeta
USE uspp, ONLY : nkb, okvan
USE wvfct, ONLY : npwx, nbnd, wg
USE uspp_param, ONLY : nh
USE ions_base, ONLY : ityp
USE control_lr, ONLY : ofsbeta
USE ldaU_ph, ONLY : proj1, projpb, projpdb
USE klist, ONLY : ngk, igk_k
USE qpoint, ONLY : ikks, ikqs

3
PHonon/PH/deallocate_phq.f90
View File

@ -36,7 +36,7 @@ subroutine deallocate_phq
vsgga, segni
USE qpoint, ONLY : eigqts, ikks, ikqs, nksq, xk_col
USE eqv, ONLY : dmuxc, vlocq, dpsi, dvpsi, evq
USE control_lr, ONLY : lgamma, nbnd_occ
USE control_lr, ONLY : lgamma, nbnd_occ, ofsbeta
USE ldaU, ONLY : lda_plus_u
USE ldaU_ph, ONLY : dnsbare_all_modes, dnsorth_cart, dnsorth, dnsbare, &
wfcatomk, swfcatomk, dwfcatomk, sdwfcatomk, &
@ -169,6 +169,7 @@ subroutine deallocate_phq
if(allocated(dwfcatomk)) deallocate (dwfcatomk)
if(allocated(sdwfcatomk)) deallocate (sdwfcatomk)
if(allocated(dvkb)) deallocate (dvkb)
if(allocated(ofsbeta)) deallocate (ofsbeta)
if(allocated(dnsbare)) deallocate (dnsbare)
if(allocated(dnsbare_all_modes)) deallocate (dnsbare_all_modes)
if(allocated(dnsorth)) deallocate (dnsorth)

3
PHonon/PH/delta_sphi.f90
View File

@ -38,13 +38,14 @@ SUBROUTINE delta_sphi (ikk, ikq, na, icart, nah, ihubst, wfcatomk_, wfcatomkpq_,
USE kinds, ONLY : DP
USE uspp_param, ONLY : nh, nhm
USE ions_base, ONLY : nat, ityp
USE uspp, ONLY : nkb, qq_nt, okvan, ofsbeta
USE uspp, ONLY : nkb, qq_nt, okvan
USE ldaU, ONLY : nwfcU
USE wvfct, ONLY : npwx
USE mp_pools, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
USE klist, ONLY : ngk
USE io_global, ONLY : stdout
USE control_lr, ONLY : ofsbeta
!
IMPLICIT NONE
!

4
PHonon/PH/dnsq_bare.f90
View File

@ -33,9 +33,9 @@ SUBROUTINE dnsq_bare
sdwfcatomk, sdwfcatomkpq, dvkb, vkbkpq, dvkbkpq, &
dnsbare, dnsbare_all_modes, proj1, proj2, read_dns_bare
USE wvfct, ONLY : npwx, wg, nbnd
USE uspp, ONLY : vkb, nkb, ofsbeta
USE uspp, ONLY : vkb, nkb
USE qpoint, ONLY : nksq, ikks, ikqs
USE control_lr, ONLY : lgamma
USE control_lr, ONLY : lgamma, ofsbeta
USE units_lr, ONLY : iuatwfc, iuatswfc
USE uspp_param, ONLY : nh, nhm
USE lsda_mod, ONLY : lsda, nspin, current_spin, isk

4
PHonon/PH/dnsq_orth.f90
View File

@ -36,13 +36,13 @@ SUBROUTINE dnsq_orth()
USE klist, ONLY : xk, wk, ngk, igk_k
USE wvfct, ONLY : npwx, wg, nbnd
USE qpoint, ONLY : nksq, ikks, ikqs
USE control_lr, ONLY : lgamma
USE control_lr, ONLY : lgamma, ofsbeta
USE units_lr, ONLY : iuatswfc
USE uspp_param, ONLY : nh
USE lsda_mod, ONLY : lsda, nspin, current_spin, isk
USE wavefunctions, ONLY : evc
USE eqv, ONLY : evq
USE uspp, ONLY : okvan, nkb, vkb, ofsbeta
USE uspp, ONLY : okvan, nkb, vkb
USE control_flags, ONLY : iverbosity
USE mp, ONLY : mp_sum, mp_bcast
USE mp_pools, ONLY : intra_pool_comm, inter_pool_comm

4
PHonon/PH/dvqhub_barepsi_us.f90
View File

@ -47,9 +47,9 @@ SUBROUTINE dvqhub_barepsi_us (ik, uact)
sdwfcatomk, sdwfcatomkpq, dvkb, vkbkpq, dvkbkpq, &
proj1, proj2, dnsbare, effU
USE wvfct, ONLY : npwx, nbnd
USE uspp, ONLY : vkb, nkb, ofsbeta
USE uspp, ONLY : vkb,nkb
USE qpoint, ONLY : nksq, ikks, ikqs
USE control_lr, ONLY : lgamma
USE control_lr, ONLY : lgamma, ofsbeta
USE units_lr, ONLY : iuatwfc, iuatswfc
USE uspp_param, ONLY : nh
USE lsda_mod, ONLY : lsda, current_spin, isk

4
PHonon/PH/dvqhub_barepsi_us2.f90
View File

@ -28,9 +28,9 @@ SUBROUTINE dvqhub_barepsi_us2 (ik, dvqhbar, dvqhbar_orth, dvqhbar_orth_lm)
sdwfcatomk, sdwfcatomkpq, dvkb, vkbkpq, dvkbkpq, &
proj1, proj2, effU
USE wvfct, ONLY : npwx, nbnd
USE uspp, ONLY : vkb, nkb, okvan, ofsbeta
USE uspp, ONLY : vkb, nkb, okvan
USE qpoint, ONLY : nksq, ikks, ikqs
USE control_lr, ONLY : lgamma
USE control_lr, ONLY : lgamma, ofsbeta
USE units_lr, ONLY : iuatwfc, iuatswfc
USE uspp_param, ONLY : nh
USE lsda_mod, ONLY : lsda, current_spin, isk

4
PHonon/PH/dynmat_hub_bare.f90
View File

@ -37,10 +37,10 @@ SUBROUTINE dynmat_hub_bare
effU, read_dns_bare, d2ns_type
USE wavefunctions, ONLY : evc
USE units_lr, ONLY : iuwfc, lrwfc, iuatwfc, iuatswfc
USE uspp, ONLY : vkb, nkb, ofsbeta
USE uspp, ONLY : vkb, nkb
USE uspp_param, ONLY : nh
USE klist, ONLY : xk, ngk, igk_k
USE control_lr, ONLY : lgamma
USE control_lr, ONLY : lgamma, ofsbeta
USE io_files, ONLY : nwordwfcU, tmp_dir
USE lsda_mod, ONLY : lsda, current_spin, isk, nspin
USE modes, ONLY : u, nmodes

2
PHonon/PH/make.depend
View File

@ -258,7 +258,6 @@ clean_pw_ph.o : phcom.o
clean_pw_ph.o : save_ph_input.o
clinear.o : ../../Modules/kind.o
close_phq.o : ../../LR_Modules/lrcom.o
close_phq.o : ../../Modules/io_files.o
close_phq.o : ../../Modules/io_global.o
close_phq.o : ../../Modules/mp_pools.o
close_phq.o : ../../PW/src/buffers.o
@ -392,6 +391,7 @@ deallocate_phq.o : ../../PW/src/ldaU.o
deallocate_phq.o : elph.o
deallocate_phq.o : phcom.o
deallocate_phq.o : ramanm.o
delta_sphi.o : ../../LR_Modules/lrcom.o
delta_sphi.o : ../../Modules/io_global.o
delta_sphi.o : ../../Modules/ions_base.o
delta_sphi.o : ../../Modules/kind.o

27
PHonon/PH/openfilq.f90
View File

@ -12,17 +12,16 @@ SUBROUTINE openfilq()
! ... This subroutine opens all the files necessary for the phononq
! ... calculation.
!
USE kinds, ONLY : DP
USE control_flags, ONLY : io_level, modenum
USE units_ph, ONLY : iudwf, iubar, iucom, iudvkb3, &
USE kinds, ONLY : DP
USE control_flags, ONLY : io_level, modenum
USE units_ph, ONLY : iudwf, iubar, iucom, iudvkb3, &
iudrhous, iuebar, iudrho, iudyn, iudvscf, &
lrdwf, lrbar, lrcom, lrdvkb3, &
lrdrhous, lrebar, lrdrho, lint3paw, iuint3paw, &
iundnsscf, iudvpsi, lrdvpsi, iugauge
USE units_lr, ONLY : iuwfc, lrwfc
USE io_files, ONLY : prefix, tmp_dir, diropn, seqopn, iunhub, &
iunhub_noS, nwordwfcU
USE control_ph, ONLY : epsil, zue, ext_recover, trans, &
USE units_lr, ONLY : iuwfc, lrwfc
USE io_files, ONLY : tmp_dir, diropn, seqopn, nwordwfcU
USE control_ph, ONLY : epsil, zue, ext_recover, trans, &
tmp_dir_phq, start_irr, last_irr, xmldyn, &
all_done, newgrid
USE save_ph, ONLY : tmp_dir_save
@ -34,6 +33,7 @@ SUBROUTINE openfilq()
USE lsda_mod, ONLY : nspin, lsda
USE uspp, ONLY : nkb, okvan
USE uspp_param, ONLY : nhm
USE io_files, ONLY : prefix
USE noncollin_module,ONLY : npol, nspin_mag, noncolin
USE paw_variables, ONLY : okpaw
USE mp_bands, ONLY : me_bgrp
@ -252,24 +252,15 @@ SUBROUTINE openfilq()
nwordwfcU = npwx * nwfcU * npol
!
! The unit iuatwfc contains atomic wfcs at k and k+q
!
!
iuatwfc = 34
CALL open_buffer (iuatwfc, 'atwfc', nwordwfcU, io_level, exst_mem, exst, tmp_dir)
!
! The unit iuatswfc contains atomic wfcs * S at k and k+q
!
!
iuatswfc = 35
CALL open_buffer (iuatswfc, 'satwfc', nwordwfcU, io_level, exst_mem, exst, tmp_dir)
!
IF (lgamma) THEN
!
! If q = Gamma, open units iunhub and iunhub_noS which are needed in
! commutator_Vhubx_psi.f90. They contain atomic wfcs phi and S * phi at k.
!
CALL open_buffer(iunhub, 'hub', nwordwfcU, io_level, exst_mem, exst, tmp_dir)
CALL open_buffer(iunhub_noS, 'hubnoS', nwordwfcU, io_level, exst_mem, exst, tmp_dir)
ENDIF
!
! Open a file to write dnsscf_all_modes
!
iundnsscf = 36

4
PHonon/PH/phq_setup.f90
View File

@ -445,6 +445,10 @@ subroutine phq_setup
! Initialize d1, d2, d3 to rotate the spherical harmonics
!
CALL d_matrix (d1, d2, d3)
!
! Calculate the offset of beta functions for all atoms.
!
CALL setup_offset_beta()
!
ENDIF
!

2
PW/CMakeLists.txt
View File

@ -32,8 +32,6 @@ set(src_pw
src/cdiagh.f90
src/clean_pw.f90
src/close_files.f90
src/commutator_Hx_psi.f90
src/commutator_Vhubx_psi.f90
src/compute_becsum.f90
src/compute_deff.f90
src/compute_dip.f90

2
PW/src/Makefile
View File

@ -43,8 +43,6 @@ orbm_kubo.o \
cdiagh.o \
clean_pw.o \
close_files.o \
commutator_Hx_psi.o \
commutator_Vhubx_psi.o \
compute_becsum.o \
compute_deff.o \
compute_dip.o \

16
PW/src/add_vuspsi.f90
View File

@ -19,7 +19,7 @@ SUBROUTINE add_vuspsi( lda, n, m, hpsi )
USE lsda_mod, ONLY: current_spin
USE control_flags, ONLY: gamma_only
USE noncollin_module
USE uspp, ONLY: vkb, nkb, deeq, deeq_nc, ofsbeta, using_vkb
USE uspp, ONLY: vkb, nkb, deeq, deeq_nc, indv_ijkb0, using_vkb
USE uspp_param, ONLY: nh, nhm
USE becmod, ONLY: bec_type, becp
USE becmod_subs_gpum, ONLY: using_becp_auto
@ -110,7 +110,7 @@ SUBROUTINE add_vuspsi( lda, n, m, hpsi )
ps(:,:) = 0.D0
!
! In becp=<vkb_i|psi_j> terms corresponding to atom na of type nt
! run from index i=ofsbeta(na)+1 to i=ofsbeta(na)+nh(nt)
! run from index i=indv_ijkb0(na)+1 to i=indv_ijkb0(na)+nh(nt)
!
DO nt = 1, ntyp
!
@ -125,8 +125,8 @@ SUBROUTINE add_vuspsi( lda, n, m, hpsi )
IF ( m_loc > 0 ) THEN
CALL DGEMM('N', 'N', nh(nt), m_loc, nh(nt), 1.0_dp, &
deeq(1,1,na,current_spin), nhm, &
becp%r(ofsbeta(na)+1,1), nkb, 0.0_dp, &
ps(ofsbeta(na)+1,1), nkb )
becp%r(indv_ijkb0(na)+1,1), nkb, 0.0_dp, &
ps(indv_ijkb0(na)+1,1), nkb )
ENDIF
!
ENDIF
@ -208,8 +208,8 @@ SUBROUTINE add_vuspsi( lda, n, m, hpsi )
deeaux(:,:) = CMPLX(deeq(1:nh(nt),1:nh(nt),na,current_spin),&
0.0_dp, KIND=dp )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
deeaux, nh(nt), becp%k(ofsbeta(na)+1,1), nkb, &
(0.0_dp, 0.0_dp), ps(ofsbeta(na)+1,1), nkb )
deeaux, nh(nt), becp%k(indv_ijkb0(na)+1,1), nkb, &
(0.0_dp, 0.0_dp), ps(indv_ijkb0(na)+1,1), nkb )
!
ENDIF
!
@ -258,11 +258,11 @@ SUBROUTINE add_vuspsi( lda, n, m, hpsi )
!
DO jh = 1, nh(nt)
!
jkb = ofsbeta(na) + jh
jkb = indv_ijkb0(na) + jh
!
DO ih = 1, nh(nt)
!
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
!
ps(ikb,1,ibnd) = ps(ikb,1,ibnd) + &
deeq_nc(ih,jh,na,1)*becp%nc(jkb,1,ibnd)+ &

28
PW/src/add_vuspsi_gpu.f90
View File

@ -19,7 +19,7 @@ SUBROUTINE add_vuspsi_gpu( lda, n, m, hpsi_d )
USE lsda_mod, ONLY: current_spin
USE control_flags, ONLY: gamma_only
USE noncollin_module
USE uspp, ONLY: ofsbeta, nkb, vkb_d, deeq_d, deeq_nc_d, using_vkb_d
USE uspp, ONLY: indv_ijkb0, nkb, vkb_d, deeq_d, deeq_nc_d, using_vkb_d
USE uspp_param, ONLY: nh, nhm
USE becmod_gpum, ONLY: bec_type_d, becp_d, using_becp_r_d, &
using_becp_k_d, using_becp_nc_d
@ -122,7 +122,7 @@ SUBROUTINE add_vuspsi_gpu( lda, n, m, hpsi_d )
ps_d(:,:) = 0.D0
!
! In becp=<vkb_i|psi_j> terms corresponding to atom na of type nt
! run from index i=ofsbeta(na)+1 to i=ofsbeta(na)+nh(nt)
! run from index i=indv_ijkb0(na)+1 to i=indv_ijkb0(na)+nh(nt)
!
DO nt = 1, ntyp
!
@ -137,8 +137,8 @@ SUBROUTINE add_vuspsi_gpu( lda, n, m, hpsi_d )
IF ( m_loc > 0 ) THEN
CALL DGEMM('N', 'N', nh(nt), m_loc, nh(nt), 1.0_dp, &
deeq_d(1,1,na,current_spin), nhm, &
becp_d%r_d(ofsbeta(na)+1,1), nkb, 0.0_dp, &
ps_d(ofsbeta(na)+1,1), nkb )
becp_d%r_d(indv_ijkb0(na)+1,1), nkb, 0.0_dp, &
ps_d(indv_ijkb0(na)+1,1), nkb )
END IF
!
END IF
@ -245,8 +245,8 @@ SUBROUTINE add_vuspsi_gpu( lda, n, m, hpsi_d )
END DO
!
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
deeaux_d, nhm, becp_d%k_d(ofsbeta(na)+1,1), nkb, &
(0.0_dp, 0.0_dp), ps_d(ofsbeta(na)+1,1), nkb )
deeaux_d, nhm, becp_d%k_d(indv_ijkb0(na)+1,1), nkb, &
(0.0_dp, 0.0_dp), ps_d(indv_ijkb0(na)+1,1), nkb )
!
END IF
!
@ -306,22 +306,22 @@ SUBROUTINE add_vuspsi_gpu( lda, n, m, hpsi_d )
IF ( ityp(na) == nt ) THEN
!
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
deeq_nc_d(1,1,na,1), nhm, becp_d%nc_d(ofsbeta(na)+1,1,1), 2*nkb, &
(0.0_dp, 0.0_dp), ps_d(ofsbeta(na)+1,1,1), 2*nkb )
deeq_nc_d(1,1,na,1), nhm, becp_d%nc_d(indv_ijkb0(na)+1,1,1), 2*nkb, &
(0.0_dp, 0.0_dp), ps_d(indv_ijkb0(na)+1,1,1), 2*nkb )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
deeq_nc_d(1,1,na,2), nhm, becp_d%nc_d(ofsbeta(na)+1,2,1), 2*nkb, &
(1.0_dp, 0.0_dp), ps_d(ofsbeta(na)+1,1,1), 2*nkb )
deeq_nc_d(1,1,na,2), nhm, becp_d%nc_d(indv_ijkb0(na)+1,2,1), 2*nkb, &
(1.0_dp, 0.0_dp), ps_d(indv_ijkb0(na)+1,1,1), 2*nkb )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
deeq_nc_d(1,1,na,3), nhm, becp_d%nc_d(ofsbeta(na)+1,1,1), 2*nkb, &
(0.0_dp, 0.0_dp), ps_d(ofsbeta(na)+1,2,1), 2*nkb )
deeq_nc_d(1,1,na,3), nhm, becp_d%nc_d(indv_ijkb0(na)+1,1,1), 2*nkb, &
(0.0_dp, 0.0_dp), ps_d(indv_ijkb0(na)+1,2,1), 2*nkb )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
deeq_nc_d(1,1,na,4), nhm, becp_d%nc_d(ofsbeta(na)+1,2,1), 2*nkb, &
(1.0_dp, 0.0_dp), ps_d(ofsbeta(na)+1,2,1), 2*nkb )
deeq_nc_d(1,1,na,4), nhm, becp_d%nc_d(indv_ijkb0(na)+1,2,1), 2*nkb, &
(1.0_dp, 0.0_dp), ps_d(indv_ijkb0(na)+1,2,1), 2*nkb )
! DO ibnd = 1, m
! !

4
PW/src/force_hub.f90
View File

@ -38,7 +38,7 @@ SUBROUTINE force_hub( forceh )
USE mp, ONLY : mp_sum
USE becmod, ONLY : bec_type, becp, calbec, allocate_bec_type, &
deallocate_bec_type
USE uspp, ONLY : nkb, vkb, ofsbeta, using_vkb
USE uspp, ONLY : nkb, vkb, indv_ijkb0, using_vkb
USE uspp_param, ONLY : nh
USE wavefunctions, ONLY : evc
USE klist, ONLY : nks, xk, ngk, igk_k
@ -155,7 +155,7 @@ SUBROUTINE force_hub( forceh )
!
DO alpha = 1, nat ! forces are calculated by displacing atom alpha ...
!
ijkb0 = ofsbeta(alpha) ! positions of beta functions for atom alpha
ijkb0 = indv_ijkb0(alpha) ! positions of beta functions for atom alpha
!
IF (lda_plus_u_kind.EQ.0) THEN
!

4
PW/src/force_hub_gpu.f90
View File

@ -38,7 +38,7 @@ SUBROUTINE force_hub_gpu( forceh )
USE mp, ONLY : mp_sum
USE becmod, ONLY : bec_type, becp, calbec, allocate_bec_type, &
deallocate_bec_type
USE uspp, ONLY : nkb, vkb, vkb_d, ofsbeta, using_vkb_d
USE uspp, ONLY : nkb, vkb, vkb_d, indv_ijkb0, using_vkb_d
USE uspp_param, ONLY : nh
USE wavefunctions, ONLY : evc
USE klist, ONLY : nks, xk, ngk, igk_k, igk_k_d
@ -176,7 +176,7 @@ SUBROUTINE force_hub_gpu( forceh )
!
DO alpha = 1, nat ! forces are calculated by displacing atom alpha ...
!
ijkb0 = ofsbeta(alpha) ! positions of beta functions for atom alpha
ijkb0 = indv_ijkb0(alpha) ! positions of beta functions for atom alpha
!
IF (lda_plus_u_kind.EQ.0) THEN
!

6
PW/src/force_us.f90
View File

@ -17,7 +17,7 @@ SUBROUTINE force_us( forcenl )
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE klist, ONLY : nks, xk, ngk, igk_k
USE gvect, ONLY : g
USE uspp, ONLY : nkb, vkb, qq_at, deeq, qq_so, deeq_nc, ofsbeta, &
USE uspp, ONLY : nkb, vkb, qq_at, deeq, qq_so, deeq_nc, indv_ijkb0, &
using_vkb
USE uspp_param, ONLY : upf, nh, nhm
USE wvfct, ONLY : nbnd, npwx, wg, et
@ -173,7 +173,7 @@ SUBROUTINE force_us( forcenl )
ALLOCATE( aux(nh(nt),becp%nbnd_loc) )
DO na = 1, nat
IF ( ityp(na) == nt ) THEN
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
! this is \sum_j q_{ij} <beta_j|psi>
CALL DGEMM( 'N','N', nh(nt), becp%nbnd_loc, nh(nt), &
1.0_dp, qq_at(1,1,na), nhm, becp%r(ijkb0+1,1), &
@ -240,7 +240,7 @@ SUBROUTINE force_us( forcenl )
!
DO nt = 1, ntyp
DO na = 1, nat
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
IF ( ityp(na) == nt ) THEN
DO ih = 1, nh(nt)
ikb = ijkb0 + ih

6
PW/src/force_us_gpu.f90
View File

@ -17,7 +17,7 @@ SUBROUTINE force_us_gpu( forcenl )
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE klist, ONLY : nks, xk, ngk, igk_k, igk_k_d
USE gvect_gpum, ONLY : g_d
USE uspp, ONLY : nkb, vkb_d, qq_at, deeq, qq_so, deeq_nc, ofsbeta, &
USE uspp, ONLY : nkb, vkb_d, qq_at, deeq, qq_so, deeq_nc, indv_ijkb0, &
using_vkb, using_vkb_d
USE uspp_param, ONLY : upf, nh, nhm
USE wvfct, ONLY : nbnd, npwx, wg, et
@ -212,7 +212,7 @@ SUBROUTINE force_us_gpu( forcenl )
DO na = 1, nat
IF ( ityp(na) == nt ) THEN
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
! this is \sum_j q_{ij} <beta_j|psi>
CALL DGEMM ('N','N', nh(nt), becp_d%nbnd_loc, nh(nt), &
1.0_dp, qq_at_d(1,1,na), nhm, becp_d%r_d(ijkb0+1,1),&
@ -280,7 +280,7 @@ SUBROUTINE force_us_gpu( forcenl )
!
DO nt = 1, ntyp
DO na = 1, nat
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
IF ( ityp(na) == nt ) THEN
DO ih = 1, nh(nt)
ikb = ijkb0 + ih

2
PW/src/hinit1.f90
View File

@ -86,7 +86,7 @@ SUBROUTINE hinit1()
! ... in LDA+U calculations
!
IF (.NOT. use_gpu) THEN
IF ( lda_plus_u ) CALL orthoUwfc(.FALSE.)
IF ( lda_plus_u ) CALL orthoUwfc()
IF ( use_wannier ) CALL orthoatwfc( .TRUE. )
ELSE
IF ( lda_plus_u ) CALL orthoUwfc_gpu()

27
PW/src/make.depend
View File

@ -381,33 +381,6 @@ close_files.o : bp_mod.o
close_files.o : buffers.o
close_files.o : ldaU.o
close_files.o : pwcom.o
commutator_Hx_psi.o : ../../Modules/becmod.o
commutator_Hx_psi.o : ../../Modules/cell_base.o
commutator_Hx_psi.o : ../../Modules/control_flags.o
commutator_Hx_psi.o : ../../Modules/io_global.o
commutator_Hx_psi.o : ../../Modules/ions_base.o
commutator_Hx_psi.o : ../../Modules/kind.o
commutator_Hx_psi.o : ../../Modules/noncol.o
commutator_Hx_psi.o : ../../Modules/recvec.o
commutator_Hx_psi.o : ../../Modules/wavefunctions.o
commutator_Hx_psi.o : ../../upflib/uspp.o
commutator_Hx_psi.o : ldaU.o
commutator_Hx_psi.o : pwcom.o
commutator_Vhubx_psi.o : ../../Modules/cell_base.o
commutator_Vhubx_psi.o : ../../Modules/io_files.o
commutator_Vhubx_psi.o : ../../Modules/ions_base.o
commutator_Vhubx_psi.o : ../../Modules/kind.o
commutator_Vhubx_psi.o : ../../Modules/mp_pools.o
commutator_Vhubx_psi.o : ../../Modules/noncol.o
commutator_Vhubx_psi.o : ../../Modules/recvec.o
commutator_Vhubx_psi.o : ../../Modules/wavefunctions.o
commutator_Vhubx_psi.o : ../../UtilXlib/mp.o
commutator_Vhubx_psi.o : ../../upflib/uspp.o
commutator_Vhubx_psi.o : atomic_wfc_mod.o
commutator_Vhubx_psi.o : buffers.o
commutator_Vhubx_psi.o : ldaU.o
commutator_Vhubx_psi.o : pwcom.o
commutator_Vhubx_psi.o : scf_mod.o
compute_becsum.o : ../../Modules/becmod.o
compute_becsum.o : ../../Modules/becmod_subs_gpu.o
compute_becsum.o : ../../Modules/control_flags.o

4
PW/src/new_ns.f90
View File

@ -231,7 +231,7 @@ SUBROUTINE compute_pproj( ik, q, p )
USE ions_base, ONLY : nat, ityp, ntyp => nsp
USE klist, ONLY : xk, igk_k, ngk
USE becmod, ONLY : becp
USE uspp, ONLY : nkb, vkb, ofsbeta, using_vkb
USE uspp, ONLY : nkb, vkb, indv_ijkb0, using_vkb
USE uspp_param, ONLY : nhm, nh
USE wvfct, ONLY : nbnd
USE wavefunctions, ONLY : evc
@ -284,7 +284,7 @@ SUBROUTINE compute_pproj( ik, q, p )
IF ( is_hubbard(nt) ) THEN
DO ib = 1, nbnd
DO ih = 1, nh(nt)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO iw = 1, nwfcU
IF ( gamma_only ) THEN
p%r(iw,ib) = p%r(iw,ib) + q(iw,ih,na)*becp%r(ikb,ib)

49
PW/src/orthoatwfc.f90
View File

@ -7,21 +7,18 @@
!
!
!-----------------------------------------------------------------------
SUBROUTINE orthoUwfc(save_wfcatom)
SUBROUTINE orthoUwfc
!-----------------------------------------------------------------------
!
! This routine saves to buffer "iunhub" atomic wavefunctions having an
! associated Hubbard U term * S, for DFT+U(+V) calculations. Same for
! Atomic wavefunctions are orthogonalized if desired, depending upon
! associated Hubbard U term * S, for DFT+U(+V) calculations. Same for
! Atomic wavefunctions are orthogonalized if desired, depending upon
! the value of "U_projection". "swfcatom" must NOT be allocated on input.
!
! If save_wfcatom == .TRUE., also write atomic wavefunctions before
! applying S to buffer.
!
USE kinds, ONLY : DP
USE buffers, ONLY : get_buffer, save_buffer
USE io_global, ONLY : stdout
USE io_files, ONLY : iunhub, iunhub_noS, nwordwfcU
USE io_files, ONLY : iunhub, nwordwfcU
USE ions_base, ONLY : nat
USE basis, ONLY : natomwfc, swfcatom
USE klist, ONLY : nks, xk, ngk, igk_k
@ -36,8 +33,6 @@ SUBROUTINE orthoUwfc(save_wfcatom)
USE becmod_subs_gpum, ONLY : using_becp_auto
IMPLICIT NONE
!
LOGICAL, INTENT(IN) :: save_wfcatom
!! If .TRUE., write atomic wavefunction before applying S to buffer
!
INTEGER :: ik, ibnd, info, i, j, k, na, nb, nt, isym, n, ntemp, m, &
l, lm, ltot, ntot, ipol, npw
@ -52,7 +47,7 @@ SUBROUTINE orthoUwfc(save_wfcatom)
ELSE IF (U_projection=="file") THEN
!
! Read atomic wavefunctions from file (produced by pmw.x). In this case,
! U-specific atomic wavefunctions wfcU coincide with atomic wavefunctions
! U-specific atomic wavefunctions wfcU coincide with atomic wavefunctions
!
WRITE( stdout,*) 'LDA+U Projector read from file '
DO ik = 1, nks
@ -65,7 +60,7 @@ SUBROUTINE orthoUwfc(save_wfcatom)
WRITE( stdout,*) 'Atomic wfc used for LDA+U Projector are NOT orthogonalized'
ELSE IF (U_projection=="ortho-atomic") THEN
orthogonalize_wfc = .TRUE.
normalize_only = .FALSE.
normalize_only = .FALSE.
WRITE( stdout,*) 'Atomic wfc used for LDA+U Projector are orthogonalized'
IF (gamma_only) CALL errore('orthoUwfc', &
'Gamma-only calculation for this case not implemented', 1 )
@ -79,17 +74,17 @@ SUBROUTINE orthoUwfc(save_wfcatom)
WRITE( stdout,*) "U_projection_type =", U_projection
CALL errore ("orthoUwfc"," this U_projection_type is not valid",1)
END IF
!
ALLOCATE ( wfcatom(npwx*npol, natomwfc), swfcatom(npwx*npol, natomwfc) )
!
save_flag = use_bgrp_in_hpsi ; use_bgrp_in_hpsi=.false.
!
! Allocate the array becp = <beta|wfcatom>
CALL allocate_bec_type (nkb,natomwfc, becp)
CALL allocate_bec_type (nkb,natomwfc, becp)
CALL using_becp_auto(2)
!
DO ik = 1, nks
!
IF (noncolin) THEN
CALL atomic_wfc_nc_updown (ik, wfcatom)
ELSE
@ -98,9 +93,9 @@ SUBROUTINE orthoUwfc(save_wfcatom)
npw = ngk (ik)
CALL using_vkb(1)
CALL init_us_2 (npw, igk_k(1,ik), xk (1, ik), vkb)
CALL calbec (npw, vkb, wfcatom, becp)
CALL calbec (npw, vkb, wfcatom, becp)
CALL s_psi (npwx, npw, natomwfc, wfcatom, swfcatom)
!
IF (orthogonalize_wfc) &
CALL ortho_swfc ( npw, normalize_only, natomwfc, wfcatom, swfcatom, .FALSE. )
!
@ -109,18 +104,8 @@ SUBROUTINE orthoUwfc(save_wfcatom)
! save to unit iunhub
!
CALL copy_U_wfc (swfcatom, noncolin)
IF ( nks > 1 ) CALL save_buffer (wfcU, nwordwfcU, iunhub, ik)
!
! If save_wfcatom=.TRUE. copy the orthonormalized wfcatom to wfcU and save
! to unit iunhubnoS
!
IF (save_wfcatom) THEN
IF (orthogonalize_wfc) THEN
CALL ortho_swfc ( npw, normalize_only, natomwfc, wfcatom, swfcatom, .TRUE. )
ENDIF
CALL copy_U_wfc (wfcatom, noncolin)
CALL save_buffer (wfcU, nwordwfcU, iunhub_noS, ik)
ENDIF
IF ( nks > 1 ) &
CALL save_buffer (wfcU, nwordwfcU, iunhub, ik)
!
ENDDO
DEALLOCATE (wfcatom, swfcatom)
@ -130,7 +115,7 @@ SUBROUTINE orthoUwfc(save_wfcatom)
use_bgrp_in_hpsi = save_flag
!
RETURN
!
!
END SUBROUTINE orthoUwfc
!
!-----------------------------------------------------------------------

8
PW/src/paw_exx.f90
View File

@ -35,7 +35,7 @@ MODULE paw_exx
USE uspp_param, ONLY : upf, nh
USE uspp, ONLY : nkb
USE paw_variables, ONLY : okpaw
USE uspp, ONLY : ofsbeta
USE uspp, ONLY : indv_ijkb0
USE io_global, ONLY : ionode, ionode_id
!
IMPLICIT NONE
@ -69,7 +69,7 @@ MODULE paw_exx
ATOMS_LOOP : &
DO na = 1, nat
IF (ityp(na)==np) THEN
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
DO uh = 1, nh(np)
ukb = ijkb0 + uh
DO oh = 1, nh(np)
@ -111,7 +111,7 @@ MODULE paw_exx
!
USE ions_base, ONLY : nat, ityp, ntyp => nsp
USE uspp_param, ONLY : nh, upf
USE uspp, ONLY : nkb, ofsbeta
USE uspp, ONLY : nkb, indv_ijkb0
USE io_global, ONLY : ionode
!
IMPLICIT NONE
@ -141,7 +141,7 @@ MODULE paw_exx
IF ( upf(np)%tpawp ) THEN
DO na = 1, nat
IF (ityp(na)==np) THEN
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
!
DO uh = 1, nh(np)
ukb = ijkb0 + uh

24
PW/src/realus.f90
View File

@ -1631,7 +1631,7 @@ MODULE realus
USE fft_base, ONLY : dffts
USE mp_bands, ONLY : intra_bgrp_comm
USE mp, ONLY : mp_sum
USE uspp, ONLY : ofsbeta
USE uspp, ONLY : indv_ijkb0
!
IMPLICIT NONE
!
@ -1680,7 +1680,7 @@ MODULE realus
!
mbia = maxbox_beta(ia) ; IF ( mbia == 0 ) CYCLE
!
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
!$omp parallel default(shared) private(ih,ikb,ir,bcr,bci)
!$omp do
DO ir =1, mbia
@ -1749,7 +1749,7 @@ MODULE realus
USE fft_base, ONLY : dffts
USE mp_bands, ONLY : intra_bgrp_comm
USE mp, ONLY : mp_sum
USE uspp, ONLY : ofsbeta
USE uspp, ONLY : indv_ijkb0
USE becmod_gpum, ONLY : using_becp_k
!
IMPLICIT NONE
@ -1796,7 +1796,7 @@ MODULE realus
!
mbia = maxbox_beta(ia) ; IF ( mbia == 0 ) CYCLE
!
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
!
!$omp parallel default(shared) private(ih,ikb,ir,bcr,bci)
!$omp do
@ -1847,7 +1847,7 @@ MODULE realus
USE cell_base, ONLY : omega
USE ions_base, ONLY : nat, nsp, ityp
USE uspp_param, ONLY : nh, nhm
USE uspp, ONLY : qq_at, ofsbeta
USE uspp, ONLY : qq_at, indv_ijkb0
USE becmod, ONLY : bec_type, becp
USE fft_base, ONLY : dffts
USE becmod_gpum, ONLY : using_becp_r
@ -1881,7 +1881,7 @@ MODULE realus
mbia = maxbox_beta(ia) ; IF ( mbia == 0 ) CYCLE
!print *, "mbia=",mbia
!
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
!
!$omp parallel
!$omp do
@ -1927,7 +1927,7 @@ MODULE realus
USE cell_base, ONLY : omega
USE ions_base, ONLY : nat, nsp, ityp
USE uspp_param, ONLY : nh, nhm
USE uspp, ONLY : qq_at, ofsbeta
USE uspp, ONLY : qq_at, indv_ijkb0
USE becmod, ONLY : bec_type, becp
USE fft_base, ONLY : dffts
USE becmod_gpum, ONLY : using_becp_k
@ -1964,7 +1964,7 @@ MODULE realus
mbia = maxbox_beta(ia) ; IF ( mbia == 0 ) CYCLE
!print *, "mbia=",mbia
!
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
!
!$omp parallel
!$omp do
@ -2013,7 +2013,7 @@ MODULE realus
USE ions_base, ONLY : nat, nsp, ityp
USE uspp_param, ONLY : nh, nhm
USE lsda_mod, ONLY : current_spin
USE uspp, ONLY : deeq, ofsbeta
USE uspp, ONLY : deeq, indv_ijkb0
USE becmod, ONLY : bec_type, becp
USE fft_base, ONLY : dffts
USE becmod_gpum, ONLY : using_becp_r
@ -2045,7 +2045,7 @@ MODULE realus
!
mbia = maxbox_beta(ia) ; IF ( mbia == 0 ) CYCLE
!
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
!
!$omp parallel
!$omp do
@ -2096,7 +2096,7 @@ MODULE realus
USE ions_base, ONLY : nat, nsp, ityp
USE uspp_param, ONLY : nh, nhm
USE lsda_mod, ONLY : current_spin
USE uspp, ONLY : deeq, ofsbeta
USE uspp, ONLY : deeq, indv_ijkb0
USE becmod, ONLY : bec_type, becp
USE fft_base, ONLY : dffts
USE becmod_gpum, ONLY : using_becp_k
@ -2129,7 +2129,7 @@ MODULE realus
!
mbia = maxbox_beta(ia) ; IF ( mbia == 0 ) CYCLE
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
!$omp parallel
!$omp do

18
PW/src/s_psi.f90
View File

@ -84,7 +84,7 @@ SUBROUTINE s_psi_( lda, n, m, psi, spsi )
!
USE kinds, ONLY: DP
USE becmod, ONLY: becp
USE uspp, ONLY: vkb, nkb, okvan, qq_at, qq_so, ofsbeta, using_vkb
USE uspp, ONLY: vkb, nkb, okvan, qq_at, qq_so, indv_ijkb0, using_vkb
USE spin_orb, ONLY: lspinorb
USE uspp_param, ONLY: upf, nh, nhm
USE ions_base, ONLY: nat, nsp, ityp
@ -229,7 +229,7 @@ SUBROUTINE s_psi_( lda, n, m, psi, spsi )
ps(:,:) = 0.0_DP
!
! In becp=<vkb_i|psi_j> terms corresponding to atom na of type nt
! run from index i=ofsbeta(na)+1 to i=ofsbeta(na)+nh(nt)
! run from index i=indv_ijkb0(na)+1 to i=indv_ijkb0(na)+nh(nt)
!
DO nt = 1, nsp
IF ( upf(nt)%tvanp ) THEN
@ -241,8 +241,8 @@ SUBROUTINE s_psi_( lda, n, m, psi, spsi )
!
IF ( m_loc > 0 ) THEN
CALL DGEMM('N', 'N', nh(nt), m_loc, nh(nt), 1.0_dp, &
qq_at(1,1,na), nhm, becp%r(ofsbeta(na)+1,1),&
nkb, 0.0_dp, ps(ofsbeta(na)+1,1), nkb )
qq_at(1,1,na), nhm, becp%r(indv_ijkb0(na)+1,1),&
nkb, 0.0_dp, ps(indv_ijkb0(na)+1,1), nkb )
ENDIF
ENDIF
ENDDO
@ -327,8 +327,8 @@ SUBROUTINE s_psi_( lda, n, m, psi, spsi )
IF ( ityp(na) == nt ) THEN
qqc(:,:) = CMPLX ( qq_at(1:nh(nt),1:nh(nt),na), 0.0_DP, KIND=DP )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_DP,0.0_DP), &
qqc, nh(nt), becp%k(ofsbeta(na)+1,1), nkb, &
(0.0_DP,0.0_DP), ps(ofsbeta(na)+1,1), nkb )
qqc, nh(nt), becp%k(indv_ijkb0(na)+1,1), nkb, &
(0.0_DP,0.0_DP), ps(indv_ijkb0(na)+1,1), nkb )
ENDIF
ENDDO
DEALLOCATE( qqc )
@ -338,7 +338,7 @@ SUBROUTINE s_psi_( lda, n, m, psi, spsi )
IF (nh(nt)>0) THEN
DO na = 1, nat
IF ( ityp(na) == nt ) THEN
ps(ofsbeta(na)+1:ofsbeta(na)+nh(nt),1:m) = (0.0_DP,0.0_DP)
ps(indv_ijkb0(na)+1:indv_ijkb0(na)+nh(nt),1:m) = (0.0_DP,0.0_DP)
ENDIF
ENDDO
ENDIF
@ -398,9 +398,9 @@ SUBROUTINE s_psi_( lda, n, m, psi, spsi )
DO na = 1, nat
IF ( ityp(na) == nt ) THEN
DO ih = 1, nh(nt)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO jh = 1, nh(nt)
jkb = ofsbeta(na) + jh
jkb = indv_ijkb0(na) + jh
IF ( .NOT. lspinorb ) THEN
DO ipol = 1, npol
DO ibnd = 1, m

32
PW/src/s_psi_gpu.f90
View File

@ -97,7 +97,7 @@ SUBROUTINE s_psi__gpu( lda, n, m, psi_d, spsi_d )
#endif
USE kinds, ONLY : DP
USE becmod_gpum, ONLY : becp_d
USE uspp, ONLY : nkb, okvan, ofsbeta, vkb_d, using_vkb_d
USE uspp, ONLY : nkb, okvan, indv_ijkb0, vkb_d, using_vkb_d
USE spin_orb, ONLY : lspinorb
USE uspp_param, ONLY : upf, nh, nhm
USE ions_base, ONLY : nat, nsp, ityp
@ -266,7 +266,7 @@ SUBROUTINE s_psi__gpu( lda, n, m, psi_d, spsi_d )
ps_d(1:nkb,1:m_max) = 0.D0
!
! In becp=<vkb_i|psi_j> terms corresponding to atom na of type nt
! run from index i=ofsbeta(na)+1 to i=ofsbeta(na)+nh(nt)
! run from index i=indv_ijkb0(na)+1 to i=indv_ijkb0(na)+nh(nt)
!
DO nt = 1, nsp
IF ( upf(nt)%tvanp ) THEN
@ -278,8 +278,8 @@ SUBROUTINE s_psi__gpu( lda, n, m, psi_d, spsi_d )
!
IF ( m_loc > 0 ) THEN
CALL DGEMM('N', 'N', nh(nt), m_loc, nh(nt), 1.0_dp, &
qq_at_d(1,1,na), nhm, becp_d%r_d(ofsbeta(na)+1,1),&
nkb, 0.0_dp, ps_d(ofsbeta(na)+1,1), nkb )
qq_at_d(1,1,na), nhm, becp_d%r_d(indv_ijkb0(na)+1,1),&
nkb, 0.0_dp, ps_d(indv_ijkb0(na)+1,1), nkb )
END IF
END IF
END DO
@ -385,8 +385,8 @@ SUBROUTINE s_psi__gpu( lda, n, m, psi_d, spsi_d )
DO na = 1, nat
IF ( ityp(na) == nt ) THEN
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
qqc_d(1,1,na), nhm, becp_d%k_d(ofsbeta(na)+1,1), nkb, &
(0.0_dp,0.0_dp), ps_d(ofsbeta(na)+1,1), nkb )
qqc_d(1,1,na), nhm, becp_d%k_d(indv_ijkb0(na)+1,1), nkb, &
(0.0_dp,0.0_dp), ps_d(indv_ijkb0(na)+1,1), nkb )
!
END IF
END DO
@ -469,8 +469,8 @@ SUBROUTINE s_psi__gpu( lda, n, m, psi_d, spsi_d )
IF ( ityp(na) == nt ) THEN
DO ipol=1,npol
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
qqc_d(1,1, na), nhm, becp_d%nc_d(ofsbeta(na)+1,ipol,1), nkb*npol, &
(0.0_dp,0.0_dp), ps_d(ofsbeta(na)+1,ipol,1), nkb*npol )
qqc_d(1,1, na), nhm, becp_d%nc_d(indv_ijkb0(na)+1,ipol,1), nkb*npol, &
(0.0_dp,0.0_dp), ps_d(indv_ijkb0(na)+1,ipol,1), nkb*npol )
END DO
END IF
END DO
@ -478,18 +478,18 @@ SUBROUTINE s_psi__gpu( lda, n, m, psi_d, spsi_d )
DO na = 1, nat
IF ( ityp(na) == nt ) THEN
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
qq_so_d(1,1,1,nt), nhm, becp_d%nc_d(ofsbeta(na)+1,1,1), nkb*npol, &
(0.0_dp,0.0_dp), ps_d(ofsbeta(na)+1,1,1), nkb*npol )
qq_so_d(1,1,1,nt), nhm, becp_d%nc_d(indv_ijkb0(na)+1,1,1), nkb*npol, &
(0.0_dp,0.0_dp), ps_d(indv_ijkb0(na)+1,1,1), nkb*npol )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
qq_so_d(1,1,2,nt), nhm, becp_d%nc_d(ofsbeta(na)+1,2,1), nkb*npol, &
(1.0_dp,0.0_dp), ps_d(ofsbeta(na)+1,1,1), nkb*npol )
qq_so_d(1,1,2,nt), nhm, becp_d%nc_d(indv_ijkb0(na)+1,2,1), nkb*npol, &
(1.0_dp,0.0_dp), ps_d(indv_ijkb0(na)+1,1,1), nkb*npol )
!
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
qq_so_d(1,1,3,nt), nhm, becp_d%nc_d(ofsbeta(na)+1,1,1), nkb*npol, &
(0.0_dp,0.0_dp), ps_d(ofsbeta(na)+1,2,1), nkb*npol )
qq_so_d(1,1,3,nt), nhm, becp_d%nc_d(indv_ijkb0(na)+1,1,1), nkb*npol, &
(0.0_dp,0.0_dp), ps_d(indv_ijkb0(na)+1,2,1), nkb*npol )
CALL ZGEMM('N','N', nh(nt), m, nh(nt), (1.0_dp,0.0_dp), &
qq_so_d(1,1,4,nt), nhm, becp_d%nc_d(ofsbeta(na)+1,2,1), nkb*npol, &
(1.0_dp,0.0_dp), ps_d(ofsbeta(na)+1,2,1), nkb*npol )
qq_so_d(1,1,4,nt), nhm, becp_d%nc_d(indv_ijkb0(na)+1,2,1), nkb*npol, &
(1.0_dp,0.0_dp), ps_d(indv_ijkb0(na)+1,2,1), nkb*npol )
END IF
END DO
END IF

18
PW/src/sum_band.f90
View File

@ -923,7 +923,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
USE becmod, ONLY : becp, calbec, allocate_bec_type
USE control_flags, ONLY : gamma_only, tqr
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE uspp, ONLY : nkb, vkb, becsum, ebecsum, ofsbeta, &
USE uspp, ONLY : nkb, vkb, becsum, ebecsum, indv_ijkb0, &
using_vkb
USE uspp_param, ONLY : upf, nh, nhm
USE wvfct, ONLY : nbnd, wg, et, current_k
@ -1017,7 +1017,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
END IF
!
! In becp=<vkb_i|psi_j> terms corresponding to atom na of type nt
! run from index i=ofsbeta(na)+1 to i=ofsbeta(na)+nh(nt)
! run from index i=indv_ijkb0(na)+1 to i=indv_ijkb0(na)+nh(nt)
!
DO na = 1, nat
!
@ -1031,7 +1031,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
!$omp parallel do default(shared), private(is,ih,ikb,ibnd)
DO is = 1, npol
DO ih = 1, nh(np)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO kbnd = 1, this_bgrp_nbnd ! ibnd_start, ibnd_end
ibnd = ibnd_start + kbnd - 1
auxk1(ibnd,ih+(is-1)*nh(np))= becp%nc(ikb,is,kbnd)
@ -1050,7 +1050,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
!
!$omp parallel do default(shared), private(ih,ikb,ibnd,ibnd_loc)
DO ih = 1, nh(np)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO ibnd_loc = 1, nbnd_loc
ibnd = (ibnd_start - 1) + ibnd_loc + becp%ibnd_begin - 1
auxg(ibnd_loc,ih)= wg(ibnd,ik)*becp%r(ikb,ibnd_loc)
@ -1058,12 +1058,12 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
END DO
!$omp end parallel do
CALL DGEMM ( 'N', 'N', nh(np), nh(np), nbnd_loc, &
1.0_dp, becp%r(ofsbeta(na)+1,1), nkb, &
1.0_dp, becp%r(indv_ijkb0(na)+1,1), nkb, &
auxg, nbnd_loc, 0.0_dp, aux_gk, nh(np) )
if (tqr) then
!$omp parallel do default(shared), private(ih,ikb,ibnd,ibnd_loc)
DO ih = 1, nh(np)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO ibnd_loc = 1, nbnd_loc
ibnd = (ibnd_start - 1) + ibnd_loc + becp%ibnd_begin - 1
auxg(ibnd_loc,ih) = et(ibnd,ik) * auxg(ibnd_loc,ih)
@ -1071,7 +1071,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
END DO
!$omp end parallel do
CALL DGEMM ( 'N', 'N', nh(np), nh(np), nbnd_loc, &
1.0_dp, becp%r(ofsbeta(na)+1,1), nkb, &
1.0_dp, becp%r(indv_ijkb0(na)+1,1), nkb, &
auxg, nbnd_loc, 0.0_dp, aux_egk, nh(np) )
end if
!
@ -1079,7 +1079,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
!
!$omp parallel do default(shared), private(ih,ikb,ibnd)
DO ih = 1, nh(np)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO kbnd = 1, this_bgrp_nbnd ! ibnd_start, ibnd_end
ibnd = ibnd_start + kbnd - 1
auxk1(ibnd,ih) = becp%k(ikb,kbnd)
@ -1097,7 +1097,7 @@ SUBROUTINE sum_bec ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd )
if (tqr) then
!$omp parallel do default(shared), private(ih,ikb,ibnd)
DO ih = 1, nh(np)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
DO kbnd = 1, this_bgrp_nbnd ! ibnd_start, ibnd_end
ibnd = ibnd_start + kbnd - 1
auxk2(ibnd,ih) = et(ibnd,ik)*auxk2(ibnd,ih)

20
PW/src/sum_band_gpu.f90
View File

@ -1062,8 +1062,8 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
USE becmod, ONLY : becp, calbec, allocate_bec_type
USE control_flags, ONLY : gamma_only, tqr
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE uspp, ONLY : nkb, becsum, ebecsum, ofsbeta, &
vkb_d, becsum_d, ebecsum_d, ofsbeta_d, using_vkb_d
USE uspp, ONLY : nkb, becsum, ebecsum, indv_ijkb0, &
vkb_d, becsum_d, ebecsum_d, indv_ijkb0_d, using_vkb_d
USE uspp_param, ONLY : upf, nh, nhm
USE wvfct, ONLY : nbnd, wg, et, current_k
USE klist, ONLY : ngk, nkstot
@ -1164,7 +1164,7 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
END IF
!
! In becp=<vkb_i|psi_j> terms corresponding to atom na of type nt
! run from index i=ofsbeta(na)+1 to i=ofsbeta(na)+nh(nt)
! run from index i=indv_ijkb0(na)+1 to i=indv_ijkb0(na)+nh(nt)
!
nhnt = nh(np)
DO na = 1, nat
@ -1180,7 +1180,7 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
!$cuf kernel do(2)
DO is = 1, npol
DO ih = 1, nhnt
ikb = ofsbeta_d(na) + ih
ikb = indv_ijkb0_d(na) + ih
DO ibnd = ibnd_start, ibnd_end
auxk1_d(ibnd,ih+(is-1)*nhnt)= becp_d_nc_d(ikb,is,ibnd)
auxk2_d(ibnd,ih+(is-1)*nhnt)= wg_d(ibnd,ik) * &
@ -1200,7 +1200,7 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
!$cuf kernel do(2)
DO ih = 1, nhnt
DO ibnd_loc = 1, nbnd_loc
ikb = ofsbeta_d(na) + ih
ikb = indv_ijkb0_d(na) + ih
ibnd = ibnd_loc + ibnd_begin - 1
auxg_d(ibnd_loc,ih) = becp_d_r_d(ikb,ibnd_loc) * wg_d(ibnd,ik)
END DO
@ -1212,21 +1212,21 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
! summation across bgrps performed outside will gives the right value.
!
CALL cublasDgemm ( 'N', 'N', nhnt, nhnt, nbnd_loc, &
1.0_dp/nbgrp, becp_d%r_d(ofsbeta(na)+1,1), nkb, &
1.0_dp/nbgrp, becp_d%r_d(indv_ijkb0(na)+1,1), nkb, &
auxg_d, nbnd_loc, 0.0_dp, aux_gk_d, nhnt )
!
if (tqr) then
CALL using_et_d(0)
!$cuf kernel do(1)
DO ih = 1, nhnt
ikb = ofsbeta_d(na) + ih
ikb = indv_ijkb0_d(na) + ih
DO ibnd_loc = 1, nbnd_loc
auxg_d(ibnd_loc,ih) = et_d(ibnd_loc,ik) * auxg_d(ibnd_loc,ih)
END DO
END DO
CALL cublasDgemm ( 'N', 'N', nhnt, nhnt, nbnd_loc, &
1.0_dp/nbgrp, becp_d%r_d(ofsbeta(na)+1,1), nkb, &
1.0_dp/nbgrp, becp_d%r_d(indv_ijkb0(na)+1,1), nkb, &
auxg_d, nbnd_loc, 0.0_dp, aux_egk_d, nhnt )
end if
!
@ -1236,7 +1236,7 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
!$cuf kernel do(2) <<<*,*>>>
DO ih = 1, nhnt
DO ibnd = ibnd_start, ibnd_end
ikb = ofsbeta_d(na) + ih
ikb = indv_ijkb0_d(na) + ih
auxk1_d(ibnd,ih) = becp_d_k_d(ikb,ibnd)
auxk2_d(ibnd,ih) = wg_d(ibnd,ik)*becp_d_k_d(ikb,ibnd)
END DO
@ -1253,7 +1253,7 @@ SUBROUTINE sum_bec_gpu ( ik, current_spin, ibnd_start, ibnd_end, this_bgrp_nbnd
!$cuf kernel do(2)
DO ih = 1, nhnt
DO ibnd = ibnd_start, ibnd_end
ikb = ofsbeta_d(na) + ih
ikb = indv_ijkb0_d(na) + ih
auxk2_d(ibnd,ih) = et_d(ibnd,ik)*auxk2_d(ibnd,ih)
END DO
END DO

28
PW/src/us_exx.f90
View File

@ -176,7 +176,7 @@ MODULE us_exx
!
USE constants, ONLY : tpi
USE ions_base, ONLY : nat, ntyp => nsp, ityp, tau
USE uspp, ONLY : nkb, vkb, okvan, ofsbeta, ijtoh
USE uspp, ONLY : nkb, vkb, okvan, indv_ijkb0, ijtoh
USE uspp_param, ONLY : upf, nh, nhm, lmaxq
USE gvect, ONLY : g, eigts1, eigts2, eigts3, mill, gstart
USE control_flags, ONLY : gamma_only
@ -262,7 +262,7 @@ MODULE us_exx
!
! ijkb0 points to the manifold of beta functions for atom na
!
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
!
aux2(:) = (0.0_dp, 0.0_dp)
DO ih = 1, nh(nt)
@ -359,7 +359,7 @@ MODULE us_exx
!
USE constants, ONLY : tpi
USE ions_base, ONLY : nat, ntyp => nsp, ityp, tau
USE uspp, ONLY : nkb, vkb, okvan, ofsbeta, ijtoh
USE uspp, ONLY : nkb, vkb, okvan, indv_ijkb0, ijtoh
USE uspp_param, ONLY : upf, nh, nhm, lmaxq
USE gvect, ONLY : gg, g, gstart, eigts1, eigts2, eigts3, mill
USE cell_base, ONLY : omega
@ -469,7 +469,7 @@ MODULE us_exx
!
! ijkb0 points to the manifold of beta functions for atom na
!
ijkb0 = ofsbeta(na)
ijkb0 = indv_ijkb0(na)
!
aux2(1:realblocksize) = CONJG( auxvc(offset+1:offset+realblocksize) ) * eigqts(na) * &
eigts1(mill(1,offset+1:offset+realblocksize), na) * &
@ -523,7 +523,7 @@ MODULE us_exx
!! \[ H = H+\sum_I |\beta_I\rangle \alpha_{Ii} \]
!
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE uspp, ONLY : nkb, okvan,ofsbeta
USE uspp, ONLY : nkb, okvan,indv_ijkb0
USE uspp_param, ONLY : upf, nh
USE wvfct, ONLY : nbnd, npwx
USE control_flags, ONLY : gamma_only
@ -570,7 +570,7 @@ MODULE us_exx
DO na = 1, nat
IF (ityp(na)==np) THEN
DO ih = 1, nh(np)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
!
IF (ABS(deexx(ikb)) < eps_occ) CYCLE
!
@ -615,7 +615,7 @@ MODULE us_exx
!
USE ions_base, ONLY : nat, ityp
USE cell_base, ONLY : omega
USE uspp, ONLY : okvan, nkb, ijtoh, ofsbeta
USE uspp, ONLY : okvan, nkb, ijtoh, indv_ijkb0
USE uspp_param, ONLY : upf, nh
USE realus, ONLY : tabxx
!
@ -647,8 +647,8 @@ MODULE us_exx
!
DO ih = 1, nh(nt)
DO jh = 1, nh(nt)
ikb = ofsbeta(ia) + ih
jkb = ofsbeta(ia) + jh
ikb = indv_ijkb0(ia) + ih
jkb = indv_ijkb0(ia) + jh
DO ir = 1, mbia
irb = tabxx(ia)%box(ir)
rho(irb) = rho(irb) + tabxx(ia)%qr(ir,ijtoh(ih,jh,nt)) &
@ -675,7 +675,7 @@ MODULE us_exx
USE cell_base, ONLY : omega
USE ions_base, ONLY : nat, ityp
USE uspp_param, ONLY : upf, nh, nhm
USE uspp, ONLY : nkb, ijtoh, ofsbeta
USE uspp, ONLY : nkb, ijtoh, indv_ijkb0
USE noncollin_module, ONLY : nspin_mag
USE fft_types, ONLY : fft_type_descriptor
USE realus, ONLY : tabxx
@ -715,7 +715,7 @@ MODULE us_exx
!
DO ih = 1, nh(nt)
DO jh = 1, nh(nt)
ijkb0 = ofsbeta(ia)
ijkb0 = indv_ijkb0(ia)
ikb = ijkb0 + ih
jkb = ijkb0 + jh
!
@ -940,7 +940,7 @@ MODULE us_exx
USE io_global, ONLY : stdout
USE ions_base, ONLY : tau, nat, ityp
USE symm_base, ONLY : irt, d1, d2, d3, s, nsym
USE uspp, ONLY : nkb, ofsbeta, nhtolm, nhtol
USE uspp, ONLY : nkb, indv_ijkb0, nhtolm, nhtol
USE uspp_param, ONLY : nh, upf
USE wvfct, ONLY : nbnd
USE becmod, ONLY : allocate_bec_type, is_allocated_bec_type
@ -1041,12 +1041,12 @@ MODULE us_exx
lm_i = nhtolm(ih,nt)
l_i = nhtol(ih,nt)
m_i = lm_i - l_i**2
ikb = ofsbeta(ma) + ih
ikb = indv_ijkb0(ma) + ih
! print*, "doing", ikb, ma, l_i, lm_i
!
DO m_o = 1, 2*l_i +1
oh = ih - m_i + m_o
okb = ofsbeta(ia) + oh
okb = indv_ijkb0(ia) + oh
! WRITE(*,'(a,5i4,2f10.3)') "okb", okb, oh, ih, m_i, m_o, &
! D(l_i)%d(m_o,m_i, isym), &
! D(l_i)%d(m_i,m_o, isym)

6
PW/src/usnldiag.f90
View File

@ -17,7 +17,7 @@ SUBROUTINE usnldiag (npw, h_diag, s_diag)
USE ions_base, ONLY: nat, ityp, ntyp => nsp
USE wvfct, ONLY: npwx
USE lsda_mod, ONLY: current_spin
USE uspp, ONLY: deeq, vkb, qq_at, qq_so, deeq_nc, ofsbeta, &
USE uspp, ONLY: deeq, vkb, qq_at, qq_so, deeq_nc, indv_ijkb0, &
using_vkb
USE uspp_param, ONLY: upf, nh
USE spin_orb, ONLY: lspinorb
@ -63,7 +63,7 @@ SUBROUTINE usnldiag (npw, h_diag, s_diag)
DO na = 1, nat
IF (ityp (na) == nt) THEN
DO ih = 1, nh(nt)
ikb = ofsbeta(na) + ih
ikb = indv_ijkb0(na) + ih
IF (lspinorb) THEN
ps1(1) = deeq_nc (ih, ih, na, 1)
ps1(2) = deeq_nc (ih, ih, na, 4)
@ -88,7 +88,7 @@ SUBROUTINE usnldiag (npw, h_diag, s_diag)
IF ( upf(nt)%tvanp .or.upf(nt)%is_multiproj ) THEN
DO jh = 1, nh (nt)
IF (jh/=ih) THEN
jkb = ofsbeta(na) + jh
jkb = indv_ijkb0(na) + jh
IF (lspinorb) THEN
ps1(1) = deeq_nc (ih, jh, na, 1)
ps1(2) = deeq_nc (ih, jh, na, 4)

14
PW/src/usnldiag_gpu.f90
View File

@ -18,7 +18,7 @@ SUBROUTINE usnldiag_gpu (npw, h_diag_d, s_diag_d)
USE kinds, ONLY: DP
USE ions_base, ONLY: nat, ityp, ntyp => nsp
USE wvfct, ONLY: npwx
USE uspp, ONLY: ofsbeta, deeq_d, vkb_d, qq_at_d, qq_so_d, &
USE uspp, ONLY: indv_ijkb0, deeq_d, vkb_d, qq_at_d, qq_so_d, &
deeq_nc_d, using_vkb_d
USE uspp_param, ONLY: upf, nh
USE spin_orb, ONLY: lspinorb
@ -73,7 +73,7 @@ CONTAINS
IF ( upf(nt)%tvanp .or. upf(nt)%is_multiproj ) THEN
DO na = 1, nat
IF (ityp (na) == nt) THEN
ijkb_start = ofsbeta(na)
ijkb_start = indv_ijkb0(na)
nh_ = nh(nt)
!$cuf kernel do(1) <<<*,*>>>
DO ig = 1, npw
@ -101,7 +101,7 @@ CONTAINS
ELSE
DO na = 1, nat
IF (ityp (na) == nt) THEN
ijkb_start = ofsbeta(na)
ijkb_start = indv_ijkb0(na)
nh_ = nh(nt)
!$cuf kernel do(1) <<<*,*>>>
DO ig = 1, npw
@ -144,7 +144,7 @@ CONTAINS
IF ( upf(nt)%tvanp .or. upf(nt)%is_multiproj ) THEN
DO na = 1, nat
IF (ityp (na) == nt) THEN
ijkb_start = ofsbeta(na)
ijkb_start = indv_ijkb0(na)
nh_ = nh(nt)
!$cuf kernel do(1) <<<*,*>>>
DO ig = 1, npw ! change this to 2*npw ?
@ -178,7 +178,7 @@ CONTAINS
ELSE
DO na = 1, nat
IF (ityp (na) == nt) THEN
ijkb_start = ofsbeta(na)
ijkb_start = indv_ijkb0(na)
nh_ = nh(nt)
!$cuf kernel do(1) <<<*,*>>>
DO ig = 1, npw
@ -227,7 +227,7 @@ CONTAINS
IF ( upf(nt)%tvanp .or. upf(nt)%is_multiproj ) THEN
DO na = 1, nat
IF (ityp (na) == nt) THEN
ijkb_start = ofsbeta(na)
ijkb_start = indv_ijkb0(na)
nh_ = nh(nt)
!$cuf kernel do(1) <<<*,*>>>
DO ig = 1, npw ! change this to 2*npw ?
@ -263,7 +263,7 @@ CONTAINS
ELSE
DO na = 1, nat
IF (ityp (na) == nt) THEN
ijkb_start = ofsbeta(na)
ijkb_start = indv_ijkb0(na)
nh_ = nh(nt)
!$cuf kernel do(1) <<<*,*>>>
DO ig = 1, npw

2
PW/src/wfcinit.f90
View File

@ -50,7 +50,7 @@ SUBROUTINE wfcinit()
! ... Orthogonalized atomic functions needed for DFT+U and other cases
!
IF ( use_wannier .OR. one_atom_occupations ) CALL orthoatwfc ( use_wannier )
IF ( lda_plus_u ) CALL orthoUwfc(.FALSE.)
IF ( lda_plus_u ) CALL orthoUwfc()
!
! ... open files/buffer for wavefunctions (nwordwfc set in openfil)
! ... io_level > 1 : open file, otherwise: open buffer

8
upflib/init_us_1.f90
View File

@ -31,9 +31,9 @@ subroutine init_us_1( nat, ityp, omega, ngm, g, gg, intra_bgrp_comm )
USE uspp_data, ONLY : nqxq, dq, nqx, spline_ps, tab, tab_d2y, qrad, &
tab_d, tab_d2y_d, qrad_d
USE uspp, ONLY : nhtol, nhtoj, nhtolm, ijtoh, dvan, qq_at, qq_nt, indv, &
ap, aainit, qq_so, dvan_so, okvan, ofsbeta, &
ap, aainit, qq_so, dvan_so, okvan, indv_ijkb0, &
nhtol_d, nhtoj_d, nhtolm_d, ijtoh_d, dvan_d, qq_at_d, &
qq_nt_d, indv_d, qq_so_d, dvan_so_d, ofsbeta_d
qq_nt_d, indv_d, qq_so_d, dvan_so_d, indv_ijkb0_d
USE uspp_param, ONLY : upf, lmaxq, nh, nhm, lmaxkb, nbetam, nsp
USE upf_spinorb, ONLY : lspinorb, rot_ylm, fcoef, fcoef_d, lmaxx
USE paw_variables,ONLY : okpaw
@ -165,7 +165,7 @@ subroutine init_us_1( nat, ityp, omega, ngm, g, gg, intra_bgrp_comm )
! atom ia in the global list of beta functions (ijkb0=0 for ia=1)
do ia = 1,nat
IF ( ityp(ia) == nt ) THEN
ofsbeta(ia) = ijkb0
indv_ijkb0(ia) = ijkb0
ijkb0 = ijkb0 + nh(nt)
END IF
enddo
@ -388,7 +388,7 @@ subroutine init_us_1( nat, ityp, omega, ngm, g, gg, intra_bgrp_comm )
dvan_d=dvan
endif
endif
ofsbeta_d=ofsbeta
indv_ijkb0_d=indv_ijkb0
!
#endif
!

74
upflib/obsolete/uspp_gpum.f90
View File

@ -15,7 +15,7 @@
#if defined(__CUDA)
USE cudafor
#endif
USE uspp, ONLY: indv_d, nhtol_d, nhtolm_d, ijtoh_d, ofsbeta_d, &
USE uspp, ONLY: indv_d, nhtol_d, nhtolm_d, ijtoh_d, indv_ijkb0_d, &
vkb_d, becsum_d, ebecsum_d, dvan_d, deeq_d, qq_nt_d, &
qq_at_d, nhtoj_d, qq_so_d, dvan_so_d, deeq_nc_d
IMPLICIT NONE
@ -33,8 +33,8 @@
LOGICAL :: nhtolm_d_ood = .false. ! used to flag out of date variables
LOGICAL :: ijtoh_ood = .false. ! used to flag out of date variables
LOGICAL :: ijtoh_d_ood = .false. ! used to flag out of date variables
LOGICAL :: ofsbeta_ood = .false. ! used to flag out of date variables
LOGICAL :: ofsbeta_d_ood = .false. ! used to flag out of date variables
LOGICAL :: indv_ijkb0_ood = .false. ! used to flag out of date variables
LOGICAL :: indv_ijkb0_d_ood = .false. ! used to flag out of date variables
LOGICAL :: vkb_ood = .false. ! used to flag out of date variables
LOGICAL :: vkb_d_ood = .false. ! used to flag out of date variables
LOGICAL :: becsum_ood = .false. ! used to flag out of date variables
@ -364,14 +364,14 @@
#endif
END SUBROUTINE using_ijtoh_d
!
SUBROUTINE using_ofsbeta(intento, debug_info)
SUBROUTINE using_indv_ijkb0(intento, debug_info)
!
! intento is used to specify what the variable will be used for :
! 0 -> in , the variable needs to be synchronized but won't be changed
! 1 -> inout , the variable needs to be synchronized AND will be changed
! 2 -> out , NO NEED to synchronize the variable, everything will be overwritten
!
USE uspp, ONLY : ofsbeta, ofsbeta_d
USE uspp, ONLY : indv_ijkb0, indv_ijkb0_d
implicit none
INTEGER, INTENT(IN) :: intento
CHARACTER(len=*), INTENT(IN), OPTIONAL :: debug_info
@ -379,66 +379,66 @@
INTEGER :: intento_
intento_ = intento
!
IF (PRESENT(debug_info) ) print *, "using_ofsbeta ", debug_info, ofsbeta_ood
IF (PRESENT(debug_info) ) print *, "using_indv_ijkb0 ", debug_info, indv_ijkb0_ood
!
IF (ofsbeta_ood) THEN
IF ((.not. allocated(ofsbeta_d)) .and. (intento_ < 2)) THEN
CALL errore('using_ofsbeta_d', 'PANIC: sync of ofsbeta from ofsbeta_d with unallocated array. Bye!!', 1)
IF (indv_ijkb0_ood) THEN
IF ((.not. allocated(indv_ijkb0_d)) .and. (intento_ < 2)) THEN
CALL errore('using_indv_ijkb0_d', 'PANIC: sync of indv_ijkb0 from indv_ijkb0_d with unallocated array. Bye!!', 1)
stop
END IF
IF (.not. allocated(ofsbeta)) THEN
IF (.not. allocated(indv_ijkb0)) THEN
IF (intento_ /= 2) THEN
print *, "WARNING: sync of ofsbeta with unallocated array and intento /= 2? Changed to 2!"
print *, "WARNING: sync of indv_ijkb0 with unallocated array and intento /= 2? Changed to 2!"
intento_ = 2
END IF
! IF (intento_ > 0) ofsbeta_d_ood = .true.
! IF (intento_ > 0) indv_ijkb0_d_ood = .true.
END IF
IF (intento_ < 2) THEN
IF ( iverbosity > 0 ) print *, "Really copied ofsbeta D->H"
ofsbeta = ofsbeta_d
IF ( iverbosity > 0 ) print *, "Really copied indv_ijkb0 D->H"
indv_ijkb0 = indv_ijkb0_d
END IF
ofsbeta_ood = .false.
indv_ijkb0_ood = .false.
ENDIF
IF (intento_ > 0) ofsbeta_d_ood = .true.
IF (intento_ > 0) indv_ijkb0_d_ood = .true.
#endif
END SUBROUTINE using_ofsbeta
END SUBROUTINE using_indv_ijkb0
!
SUBROUTINE using_ofsbeta_d(intento, debug_info)
SUBROUTINE using_indv_ijkb0_d(intento, debug_info)
!
USE uspp, ONLY : ofsbeta, ofsbeta_d
USE uspp, ONLY : indv_ijkb0, indv_ijkb0_d
implicit none
INTEGER, INTENT(IN) :: intento
CHARACTER(len=*), INTENT(IN), OPTIONAL :: debug_info
#if defined(__CUDA) || defined(__CUDA_GNU)
!
IF (PRESENT(debug_info) ) print *, "using_ofsbeta_d ", debug_info, ofsbeta_d_ood
IF (PRESENT(debug_info) ) print *, "using_indv_ijkb0_d ", debug_info, indv_ijkb0_d_ood
!
IF (.not. allocated(ofsbeta)) THEN
IF (intento /= 2) print *, "WARNING: sync of ofsbeta_d with unallocated array and intento /= 2?"
IF (allocated(ofsbeta_d)) DEALLOCATE(ofsbeta_d)
ofsbeta_d_ood = .false.
IF (.not. allocated(indv_ijkb0)) THEN
IF (intento /= 2) print *, "WARNING: sync of indv_ijkb0_d with unallocated array and intento /= 2?"
IF (allocated(indv_ijkb0_d)) DEALLOCATE(indv_ijkb0_d)
indv_ijkb0_d_ood = .false.
RETURN
END IF
! here we know that ofsbeta is allocated, check if size is 0
IF ( SIZE(ofsbeta) == 0 ) THEN
print *, "Refusing to allocate 0 dimensional array ofsbeta_d. If used, code will crash."
! here we know that indv_ijkb0 is allocated, check if size is 0
IF ( SIZE(indv_ijkb0) == 0 ) THEN
print *, "Refusing to allocate 0 dimensional array indv_ijkb0_d. If used, code will crash."
RETURN
END IF
!
IF (ofsbeta_d_ood) THEN
IF ( allocated(ofsbeta_d) .and. (SIZE(ofsbeta_d)/=SIZE(ofsbeta))) deallocate(ofsbeta_d)
IF (.not. allocated(ofsbeta_d)) ALLOCATE(ofsbeta_d(DIMS1D(ofsbeta))) ! MOLD does not work on all compilers
IF (indv_ijkb0_d_ood) THEN
IF ( allocated(indv_ijkb0_d) .and. (SIZE(indv_ijkb0_d)/=SIZE(indv_ijkb0))) deallocate(indv_ijkb0_d)
IF (.not. allocated(indv_ijkb0_d)) ALLOCATE(indv_ijkb0_d(DIMS1D(indv_ijkb0))) ! MOLD does not work on all compilers
IF (intento < 2) THEN
IF ( iverbosity > 0 ) print *, "Really copied ofsbeta H->D"
ofsbeta_d = ofsbeta
IF ( iverbosity > 0 ) print *, "Really copied indv_ijkb0 H->D"
indv_ijkb0_d = indv_ijkb0
END IF
ofsbeta_d_ood = .false.
indv_ijkb0_d_ood = .false.
ENDIF
IF (intento > 0) ofsbeta_ood = .true.
IF (intento > 0) indv_ijkb0_ood = .true.
#else
CALL errore('using_ofsbeta_d', 'Trying to use device data without device compilated code!', 1)
CALL errore('using_indv_ijkb0_d', 'Trying to use device data without device compilated code!', 1)
#endif
END SUBROUTINE using_ofsbeta_d
END SUBROUTINE using_indv_ijkb0_d
!
SUBROUTINE using_vkb(intento, debug_info)
!
@ -1281,7 +1281,7 @@
nhtol_d_ood = .false.
nhtolm_d_ood = .false.
ijtoh_d_ood = .false.
ofsbeta_d_ood = .false.
indv_ijkb0_d_ood = .false.
vkb_d_ood = .false.
becsum_d_ood = .false.
ebecsum_d_ood = .false.

18
upflib/uspp.f90
View File

@ -85,10 +85,10 @@ MODULE uspp
PRIVATE
SAVE
!
PUBLIC :: nlx, lpx, lpl, ap, aainit, indv, nhtol, nhtolm, ofsbeta, &
PUBLIC :: nlx, lpx, lpl, ap, aainit, indv, nhtol, nhtolm, indv_ijkb0, &
nkb, nkbus, vkb, dvan, deeq, qq_at, qq_nt, nhtoj, ijtoh, beta, &
becsum, ebecsum
PUBLIC :: lpx_d, lpl_d, ap_d, indv_d, nhtol_d, nhtolm_d, ofsbeta_d, &
PUBLIC :: lpx_d, lpl_d, ap_d, indv_d, nhtol_d, nhtolm_d, indv_ijkb0_d, &
vkb_d, dvan_d, deeq_d, qq_at_d, qq_nt_d, nhtoj_d, ijtoh_d, &
becsum_d, ebecsum_d
PUBLIC :: okvan, nlcc_any
@ -133,7 +133,7 @@ MODULE uspp
nhtol(:,:), &! correspondence n <-> angular momentum l
nhtolm(:,:), &! correspondence n <-> combined lm index for (l,m)
ijtoh(:,:,:), &! correspondence beta indexes ih,jh -> composite index ijh
ofsbeta(:) ! first beta (index in the solid) for each atom
indv_ijkb0(:) ! first beta (index in the solid) for each atom
!
! GPU vars
!
@ -141,9 +141,9 @@ MODULE uspp
INTEGER, ALLOCATABLE :: nhtol_d(:,:)
INTEGER, ALLOCATABLE :: nhtolm_d(:,:)
INTEGER, ALLOCATABLE :: ijtoh_d(:,:,:)
INTEGER, ALLOCATABLE :: ofsbeta_d(:)
INTEGER, ALLOCATABLE :: indv_ijkb0_d(:)
#if defined (__CUDA)
attributes(DEVICE) :: indv_d, nhtol_d, nhtolm_d, ijtoh_d, ofsbeta_d
attributes(DEVICE) :: indv_d, nhtol_d, nhtolm_d, ijtoh_d, indv_ijkb0_d
#endif
LOGICAL :: &
@ -439,7 +439,7 @@ CONTAINS
if (tqr) then
allocate(ebecsum( nhm*(nhm+1)/2, nat, nspin))
endif
allocate( ofsbeta(nat) )
allocate( indv_ijkb0(nat) )
!
! GPU-vars (protecting zero-size allocations)
!
@ -470,7 +470,7 @@ CONTAINS
endif
!
endif
allocate( ofsbeta_d(nat) )
allocate( indv_ijkb0_d(nat) )
!
endif
!
@ -484,7 +484,7 @@ CONTAINS
IF( ALLOCATED( indv ) ) DEALLOCATE( indv )
IF( ALLOCATED( nhtolm ) ) DEALLOCATE( nhtolm )
IF( ALLOCATED( nhtoj ) ) DEALLOCATE( nhtoj )
IF( ALLOCATED( ofsbeta ) ) DEALLOCATE( ofsbeta )
IF( ALLOCATED( indv_ijkb0 ) ) DEALLOCATE( indv_ijkb0 )
IF( ALLOCATED( ijtoh ) ) DEALLOCATE( ijtoh )
IF( ALLOCATED( vkb ) ) DEALLOCATE( vkb )
IF( ALLOCATED( becsum ) ) DEALLOCATE( becsum )
@ -508,7 +508,7 @@ CONTAINS
IF( ALLOCATED( nhtol_d ) ) DEALLOCATE( nhtol_d )
IF( ALLOCATED( nhtolm_d ) ) DEALLOCATE( nhtolm_d )
IF( ALLOCATED( ijtoh_d ) ) DEALLOCATE( ijtoh_d )
IF( ALLOCATED( ofsbeta_d)) DEALLOCATE( ofsbeta_d )
IF( ALLOCATED( indv_ijkb0_d)) DEALLOCATE( indv_ijkb0_d )
IF( ALLOCATED( vkb_d ) ) DEALLOCATE( vkb_d )
IF( ALLOCATED( becsum_d ) ) DEALLOCATE( becsum_d )
IF( ALLOCATED( ebecsum_d ) ) DEALLOCATE( ebecsum_d )