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

Added k-resolved dos (GuidoF) + source "normalization" 

git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@6840 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
giannozz 2010-06-14 13:45:31 +00:00
parent 9f6796f4cc
commit c60df7459d
61 changed files with 9831 additions and 9689 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
PP/add_shift_cc.f90
View File

@ -7,7 +7,7 @@
!
!
!-----------------------------------------------------------------------
subroutine add_shift_cc (shift_cc)
SUBROUTINE add_shift_cc (shift_cc)
!----------------------------------------------------------------------
!
USE kinds, ONLY : DP
@ -26,7 +26,7 @@ subroutine add_shift_cc (shift_cc)
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
implicit none
IMPLICIT NONE
!
! first the dummy variable
!
@ -34,81 +34,81 @@ subroutine add_shift_cc (shift_cc)
real(DP) :: shift_cc (nat)
! output: the local forces on atoms
integer :: ig, ir, nt, na
INTEGER :: ig, ir, nt, na
! counter on G vectors
! counter on FFT grid points
! counter on types of atoms
! counter on atoms
real(DP), allocatable :: vxc (:,:), rhocg (:), shift_(:)
real(DP), ALLOCATABLE :: vxc (:,:), rhocg (:), shift_(:)
! exchange-correlation potential
! radial fourier trasform of rho core
real(DP) :: arg, fact
!
if ( ANY (upf(1:ntyp)%nlcc) ) goto 15
return
IF ( any (upf(1:ntyp)%nlcc) ) GOTO 15
RETURN
!
15 continue
call infomsg ('add_shift_cc','BEWARE: shift with CC never tested !!!')
if (gamma_only) then
15 CONTINUE
CALL infomsg ('add_shift_cc','BEWARE: shift with CC never tested !!!')
IF (gamma_only) THEN
fact = 2.d0
else
ELSE
fact = 1.d0
end if
ENDIF
!
! recalculate the exchange-correlation potential
!
allocate ( vxc(nrxx,nspin), shift_(nat) )
ALLOCATE ( vxc(nrxx,nspin), shift_(nat) )
shift_(:) = 0.d0
!
call v_xc (rho, rho_core, rhog_core, etxc, vtxc, vxc)
CALL v_xc (rho, rho_core, rhog_core, etxc, vtxc, vxc)
!
if (nspin.eq.1) then
do ir = 1, nrxx
IF (nspin==1) THEN
DO ir = 1, nrxx
psic (ir) = vxc (ir, 1)
enddo
else
do ir = 1, nrxx
ENDDO
ELSE
DO ir = 1, nrxx
psic (ir) = 0.5d0 * (vxc (ir, 1) + vxc (ir, 2) )
enddo
endif
deallocate (vxc)
call cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
ENDDO
ENDIF
DEALLOCATE (vxc)
CALL cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
! psic contains now Vxc(G)
!
allocate ( rhocg(ngl) )
ALLOCATE ( rhocg(ngl) )
!
! core correction term: sum on g of omega*ig*exp(-i*r_i*g)*n_core(g)*vxc
! g = 0 term gives no contribution
!
do nt = 1, ntyp
if ( upf(nt)%nlcc ) then
DO nt = 1, ntyp
IF ( upf(nt)%nlcc ) THEN
call drhoc (ngl, gl, omega, tpiba2, rgrid(nt)%mesh, rgrid(nt)%r, &
CALL drhoc (ngl, gl, omega, tpiba2, rgrid(nt)%mesh, rgrid(nt)%r, &
rgrid(nt)%rab, upf(nt)%rho_atc, rhocg)
do na = 1, nat
if (nt == ityp (na) ) then
if (gstart.eq.2) shift_(na) = omega * rhocg (igtongl (1) ) * &
CONJG(psic (nl (1) ) )
do ig = gstart, ngm
DO na = 1, nat
IF (nt == ityp (na) ) THEN
IF (gstart==2) shift_(na) = omega * rhocg (igtongl (1) ) * &
conjg(psic (nl (1) ) )
DO ig = gstart, ngm
arg = (g (1, ig) * tau (1, na) + g (2, ig) * tau (2, na) &
+ g (3, ig) * tau (3, na) ) * tpi
shift_ (na) = shift_( na) + omega * &
rhocg (igtongl (ig) ) * CONJG(psic (nl (ig) ) ) * &
CMPLX( cos(arg), -sin(arg),kind=DP) * fact
enddo
endif
enddo
endif
enddo
rhocg (igtongl (ig) ) * conjg(psic (nl (ig) ) ) * &
cmplx( cos(arg), -sin(arg),kind=DP) * fact
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
#ifdef __PARA
call mp_sum( shift_ , intra_pool_comm )
CALL mp_sum( shift_ , intra_pool_comm )
#endif
shift_cc(:) = shift_cc(:) + shift_(:)
deallocate (rhocg, shift_)
DEALLOCATE (rhocg, shift_)
!
return
end subroutine add_shift_cc
RETURN
END SUBROUTINE add_shift_cc

44
PP/add_shift_lc.f90
View File

@ -7,7 +7,7 @@
!
!
!----------------------------------------------------------------------
subroutine add_shift_lc (nat, tau, ityp, alat, omega, ngm, ngl, &
SUBROUTINE add_shift_lc (nat, tau, ityp, alat, omega, ngm, ngl, &
igtongl, nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, g, rho, nl, &
nspin, gstart, gamma_only, vloc, shift_lc)
!----------------------------------------------------------------------
@ -17,11 +17,11 @@ subroutine add_shift_lc (nat, tau, ityp, alat, omega, ngm, ngl, &
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
implicit none
IMPLICIT NONE
!
! first the dummy variables
!
integer :: nat, ngm, nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, nspin, &
INTEGER :: nat, ngm, nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, nspin, &
ngl, gstart, igtongl (ngm), nl (ngm), ityp (nat)
! input: the number of atoms in the cell
! input: the number of G vectors
@ -32,7 +32,7 @@ subroutine add_shift_lc (nat, tau, ityp, alat, omega, ngm, ngl, &
! input: the correspondence fft mesh <-> G vec
! input: the types of atoms
logical :: gamma_only
LOGICAL :: gamma_only
real(DP) :: tau (3, nat), g (3, ngm), vloc (ngl, * ), &
rho (nrxx, nspin), alat, omega
@ -46,52 +46,52 @@ subroutine add_shift_lc (nat, tau, ityp, alat, omega, ngm, ngl, &
real(DP) :: shift_lc ( nat)
! output: the local forces on atoms
integer :: ig, na
INTEGER :: ig, na
! counter on G vectors
! counter on atoms
real(DP), allocatable :: aux (:,:), shift_(:)
real(DP), ALLOCATABLE :: aux (:,:), shift_(:)
! auxiliary space for FFT
real(DP) :: arg, fact
!
! contribution to the force from the local part of the bare potential
! F_loc = Omega \Sum_G n*(G) d V_loc(G)/d R_i
!
allocate (aux(2, nrxx), shift_(nat) )
ALLOCATE (aux(2, nrxx), shift_(nat) )
shift_(:) = 0.d0
aux(1,:) = rho(:,1)
if (nspin.eq.2) aux(1,:) = aux(1,:) + rho(:,2)
IF (nspin==2) aux(1,:) = aux(1,:) + rho(:,2)
aux(2,:) = 0.d0
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
CALL cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
! aux contains now n(G)
!
if (gamma_only) then
IF (gamma_only) THEN
fact = 2.d0
else
ELSE
fact = 1.d0
end if
do na = 1, nat
ENDIF
DO na = 1, nat
! contribution from G=0 is not zero but should be counted only once
if (gstart.eq.2) shift_(na)=vloc(igtongl(1),ityp(na))*aux(1,nl(1))/ fact
do ig = gstart, ngm
IF (gstart==2) shift_(na)=vloc(igtongl(1),ityp(na))*aux(1,nl(1))/ fact
DO ig = gstart, ngm
arg = (g (1, ig) * tau (1, na) + g (2, ig) * tau (2, na) + &
g (3, ig) * tau (3, na) ) * tpi
shift_ ( na) = shift_ (na) + &
vloc (igtongl (ig), ityp (na) ) * &
(cos (arg) * aux(1,nl(ig)) - sin (arg) * aux(2,nl(ig)) )
enddo
shift_ (na) = fact * shift_ (na) * omega
enddo
ENDDO
shift_ (na) = fact * shift_ (na) * omega
ENDDO
#ifdef __PARA
call mp_sum( shift_, intra_pool_comm )
CALL mp_sum( shift_, intra_pool_comm )
#endif
shift_lc(:) = shift_lc(:) + shift_(:)
deallocate (aux,shift_)
DEALLOCATE (aux,shift_)
return
end subroutine add_shift_lc
RETURN
END SUBROUTINE add_shift_lc

96
PP/add_shift_us.f90
View File

@ -45,7 +45,7 @@ SUBROUTINE add_shift_us( shift_nl )
!
CALL add_shift_us_k()
!
END IF
ENDIF
!
RETURN
!
@ -63,15 +63,15 @@ SUBROUTINE add_shift_us( shift_nl )
IMPLICIT NONE
!
REAL(DP), ALLOCATABLE :: rbecp(:,:), shift_(:)
! auxiliary variables contain <beta|psi>
! auxiliary variables contain <beta|psi>
REAL(DP) :: ps
INTEGER :: ik, ibnd, ih, jh, na, nt, ikb, jkb, ijkb0
! counters
!
!
!
ALLOCATE( rbecp( nkb, nbnd ), shift_(nat) )
!
ALLOCATE( rbecp( nkb, nbnd ), shift_(nat) )
!
shift_(:) = 0.d0
!
! ... the forces are a sum over the K points and the bands
@ -79,11 +79,11 @@ SUBROUTINE add_shift_us( shift_nl )
DO ik = 1, nks
IF ( lsda ) current_spin = isk(ik)
!
call gk_sort (xk(1,ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL gk_sort (xk(1,ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
IF ( nks > 1 ) THEN
CALL davcio( evc, nwordwfc, iunwfc, ik, -1 )
IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb )
END IF
ENDIF
!
CALL calbec ( npw, vkb, evc, rbecp )
!
@ -98,12 +98,12 @@ SUBROUTINE add_shift_us( shift_nl )
et(ibnd,ik) * qq(ih,ih,nt)
shift_(na) = shift_(na) + ps * wg(ibnd,ik) * &
rbecp(ikb,ibnd) * rbecp(ikb,ibnd)
END DO
ENDDO
!
IF ( upf(nt)%tvanp .OR. newpseudo(nt) ) THEN
IF ( upf(nt)%tvanp .or. newpseudo(nt) ) THEN
!
! ... in US case there is a contribution for jh<>ih.
! ... We use here the symmetry in the interchange
! ... in US case there is a contribution for jh<>ih.
! ... We use here the symmetry in the interchange
! ... of ih and jh
!
DO jh = ( ih + 1 ), nh(nt)
@ -112,49 +112,49 @@ SUBROUTINE add_shift_us( shift_nl )
ps = deeq(ih,jh,na,current_spin) - &
et(ibnd,ik) * qq(ih,jh,nt)
shift_(na) = shift_(na) + ps * wg(ibnd,ik) * &
2.d0 *rbecp(ikb,ibnd) *rbecp(jkb,ibnd)
END DO
END DO
END IF
END DO
2.d0 *rbecp(ikb,ibnd) *rbecp(jkb,ibnd)
ENDDO
ENDDO
ENDIF
ENDDO
ijkb0 = ijkb0 + nh(nt)
END IF
END DO
END DO
END DO
ENDIF
ENDDO
ENDDO
ENDDO
!
#ifdef __PARA
!
! ... collect contributions across pools
!
call mp_sum( shift_, inter_pool_comm )
CALL mp_sum( shift_, inter_pool_comm )
#endif
!
! ... Since our summation over k points was only on the irreducible
! ... BZ we have to symmetrize the shifts.
! ... Since our summation over k points was only on the irreducible
! ... BZ we have to symmetrize the shifts.
!
CALL symscalar( nat, shift_ )
!
shift_nl(:) = shift_nl(:) + shift_(:)
!
DEALLOCATE( rbecp, shift_ )
DEALLOCATE( rbecp, shift_ )
!
RETURN
!
END SUBROUTINE add_shift_us_gamma
!
!
!-----------------------------------------------------------------------
SUBROUTINE add_shift_us_k()
!-----------------------------------------------------------------------
!
!
USE mp_global, ONLY: inter_pool_comm, intra_pool_comm
USE mp, ONLY: mp_sum
IMPLICIT NONE
!
REAL(DP), ALLOCATABLE :: shift_(:)
! auxiliary variable
COMPLEX(DP), ALLOCATABLE :: becp(:,:)
! auxiliary variable
COMPLEX(DP), ALLOCATABLE :: becp(:,:)
! contains products of wavefunctions and beta
REAL(DP) :: ps
@ -163,17 +163,17 @@ SUBROUTINE add_shift_us( shift_nl )
!
ALLOCATE( becp(nkb,nbnd), shift_( nat ) )
shift_(:) = 0.D0
!
!
! ... the shifts are a sum over the K points and the bands
!
DO ik = 1, nks
IF ( lsda ) current_spin = isk(ik)
!
call gk_sort (xk(1,ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL gk_sort (xk(1,ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
IF ( nks > 1 ) THEN
CALL davcio( evc, nwordwfc, iunwfc, ik, -1 )
IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb )
END IF
ENDIF
!
CALL calbec( npw, vkb, evc, becp )
!
@ -187,14 +187,14 @@ SUBROUTINE add_shift_us( shift_nl )
ps = deeq(ih,ih,na,current_spin) - &
et(ibnd,ik) * qq(ih,ih,nt)
shift_(na) = shift_(na) + ps * wg(ibnd,ik) * &
DBLE( CONJG( becp(ikb,ibnd) ) * &
dble( conjg( becp(ikb,ibnd) ) * &
becp(ikb,ibnd) )
END DO
ENDDO
!
IF ( upf(nt)%tvanp .OR. newpseudo(nt) ) THEN
IF ( upf(nt)%tvanp .or. newpseudo(nt) ) THEN
!
! ... in US case there is a contribution for jh<>ih.
! ... We use here the symmetry in the interchange
! ... in US case there is a contribution for jh<>ih.
! ... We use here the symmetry in the interchange
! ... of ih and jh
!
DO jh = ( ih + 1 ), nh(nt)
@ -203,27 +203,27 @@ SUBROUTINE add_shift_us( shift_nl )
ps = deeq(ih,jh,na,current_spin) - &
et(ibnd,ik) * qq (ih,jh,nt)
shift_(na) = shift_ (na) + ps * wg(ibnd,ik) * &
2.d0 * DBLE( CONJG( becp(ikb,ibnd) ) * &
2.d0 * dble( conjg( becp(ikb,ibnd) ) * &
becp(jkb,ibnd) )
END DO
END DO
END IF
END DO
ENDDO
ENDDO
ENDIF
ENDDO
ijkb0 = ijkb0 + nh(nt)
END IF
END DO
END DO
END DO
ENDIF
ENDDO
ENDDO
ENDDO
!
#ifdef __PARA
!
! ... collect contributions across pools
!
call mp_sum( shift_, inter_pool_comm )
CALL mp_sum( shift_, inter_pool_comm )
#endif
!
! ... Since our summation over k points was only on the irreducible
! ... BZ we have to symmetrize the forces.
! ... Since our summation over k points was only on the irreducible
! ... BZ we have to symmetrize the forces.
!
CALL symscalar( nat, shift_ )
!
@ -234,5 +234,5 @@ SUBROUTINE add_shift_us( shift_nl )
RETURN
!
END SUBROUTINE add_shift_us_k
!
!
END SUBROUTINE add_shift_us

84
PP/addusdens1d.f90
View File

@ -7,7 +7,7 @@
!
!
!----------------------------------------------------------------------
subroutine addusdens1d (plan, prho)
SUBROUTINE addusdens1d (plan, prho)
!----------------------------------------------------------------------
!
! This routine adds to the charge density the part which is due to
@ -15,7 +15,7 @@ subroutine addusdens1d (plan, prho)
! reciprocal space. The output of the routine is the planar average
! of the charge density.
!
USE kinds, only: DP
USE kinds, ONLY: DP
USE cell_base, ONLY: alat, omega, celldm
USE ions_base, ONLY: nat, ntyp => nsp, ityp
USE gvect, ONLY: nr3, nrx3, nrxx, nl, eigts1, eigts2, eigts3, ig1,ig2,ig3
@ -28,8 +28,8 @@ subroutine addusdens1d (plan, prho)
!
! here the local variables
!
implicit none
integer :: ig, na, nt, ih, jh, ijh, ngm1d, ig1dto3d (nr3), &
IMPLICIT NONE
INTEGER :: ig, na, nt, ih, jh, ijh, ngm1d, ig1dto3d (nr3), &
igtongl1d (nr3), nl1d (nr3)
! counter on G vectors
! counter on atoms
@ -53,73 +53,73 @@ subroutine addusdens1d (plan, prho)
! imaginary part of qg
! the spherical harmonics
complex(DP) :: skk, prho (nrxx), qg (nrx3)
COMPLEX(DP) :: skk, prho (nrxx), qg (nrx3)
! auxiliary variable
! auxiliary space for the charge
! auxiliary variable for FFT
! auxiliary variable for rho(G,nspin)
complex(DP), allocatable :: qgm(:), aux (:)
COMPLEX(DP), ALLOCATABLE :: qgm(:), aux (:)
call ggen1d (ngm1d, g1d, gg1d, ig1dto3d, nl1d, igtongl1d)
allocate (qgm(ngm1d), aux(ngm1d))
do ig = 1, ngm1d
CALL ggen1d (ngm1d, g1d, gg1d, ig1dto3d, nl1d, igtongl1d)
ALLOCATE (qgm(ngm1d), aux(ngm1d))
DO ig = 1, ngm1d
qmod (ig) = sqrt (gg1d (ig) )
enddo
ENDDO
aux(:) = (0.d0, 0.d0)
if (ngm1d > 0) then
call ylmr2 (lmaxq * lmaxq, ngm1d, g1d, gg1d, ylmk0)
do nt = 1, ntyp
if (upf(nt)%tvanp ) then
IF (ngm1d > 0) THEN
CALL ylmr2 (lmaxq * lmaxq, ngm1d, g1d, gg1d, ylmk0)
DO nt = 1, ntyp
IF (upf(nt)%tvanp ) THEN
ijh = 0
do ih = 1, nh (nt)
do jh = ih, nh (nt)
call qvan2 (ngm1d, ih, jh, nt, qmod, qgm, ylmk0)
DO ih = 1, nh (nt)
DO jh = ih, nh (nt)
CALL qvan2 (ngm1d, ih, jh, nt, qmod, qgm, ylmk0)
ijh = ijh + 1
do na = 1, nat
DO na = 1, nat
if (ityp (na) == nt) then
IF (ityp (na) == nt) THEN
!
! Multiply becsum and qg with the correct structure factor
!
do ig = 1, ngm1d
DO ig = 1, ngm1d
skk = eigts1 (ig1 (ig1dto3d (ig) ), na) * &
eigts2 (ig2 (ig1dto3d (ig) ), na) * &
eigts3 (ig3 (ig1dto3d (ig) ), na)
aux (ig) = aux (ig) + qgm (ig) * skk * &
becsum (ijh, na, current_spin)
enddo
endif
enddo
enddo
enddo
endif
enddo
ENDDO
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDDO
!
! adds to the charge density and converts to real space
!
qg(:) = (0.d0, 0.d0)
do ig = 1, ngm1d
DO ig = 1, ngm1d
qg (nl1d (ig) ) = aux (ig) + prho (nl (ig1dto3d (ig) ) )
enddo
else
ENDDO
ELSE
qg(:) = (0.d0, 0.d0)
endif
ENDIF
#ifdef __PARA
call mp_sum( qg, intra_pool_comm )
CALL mp_sum( qg, intra_pool_comm )
#endif
dimz = alat * celldm (3)
do ig = 1, nr3
qgr (ig) = DBLE (qg (ig) )
qgi (ig) = AIMAG (qg (ig) )
enddo
call cft (qgr, qgi, nr3, nr3, nr3, 1)
do ig = 1, nr3
DO ig = 1, nr3
qgr (ig) = dble (qg (ig) )
qgi (ig) = aimag (qg (ig) )
ENDDO
CALL cft (qgr, qgi, nr3, nr3, nr3, 1)
DO ig = 1, nr3
plan (ig) = qgr (ig) * omega / dimz
enddo
deallocate (aux, qgm)
ENDDO
DEALLOCATE (aux, qgm)
return
end subroutine addusdens1d
RETURN
END SUBROUTINE addusdens1d

138
PP/atomic_wfc_nc_proj.f90
View File

@ -12,8 +12,8 @@ SUBROUTINE atomic_wfc_nc_proj (ik, wfcatom)
!
! This routine computes the superposition of atomic wavefunctions
! for k-point "ik" - output in "wfcatom" - noncolinear case only
! If lspinorb=.TRUE. it makes linear combinations of eigenstates of
! the atomic total angular momenta j and j_z; otherwise, of eigenstates of
! If lspinorb=.TRUE. it makes linear combinations of eigenstates of
! the atomic total angular momenta j and j_z; otherwise, of eigenstates of
! the orbital angular momenta l, l_z and of s_z (the z-component of the spin).
!
USE kinds, ONLY : DP
@ -29,61 +29,61 @@ SUBROUTINE atomic_wfc_nc_proj (ik, wfcatom)
USE noncollin_module, ONLY : noncolin, npol, angle1, angle2
USE spin_orb, ONLY : lspinorb, rot_ylm, fcoef, lmaxx
!
implicit none
IMPLICIT NONE
!
integer, intent(in) :: ik
complex(DP), intent(out) :: wfcatom (npwx, npol, natomwfc)
INTEGER, INTENT(in) :: ik
COMPLEX(DP), INTENT(out) :: wfcatom (npwx, npol, natomwfc)
!
integer :: n_starting_wfc, lmax_wfc, nt, l, nb, na, m, lm, ig, iig, &
INTEGER :: n_starting_wfc, lmax_wfc, nt, l, nb, na, m, lm, ig, iig, &
i0, i1, i2, i3, nwfcm
real(DP), allocatable :: qg(:), ylm (:,:), chiq (:,:,:), gk (:,:)
complex(DP), allocatable :: sk (:), aux(:)
complex(DP) :: kphase, lphase
real(DP), ALLOCATABLE :: qg(:), ylm (:,:), chiq (:,:,:), gk (:,:)
COMPLEX(DP), ALLOCATABLE :: sk (:), aux(:)
COMPLEX(DP) :: kphase, lphase
real(DP) :: arg, px, ux, vx, wx
call start_clock ('atomic_wfc')
CALL start_clock ('atomic_wfc')
! calculate max angular momentum required in wavefunctions
lmax_wfc = 0
do nt = 1, ntyp
lmax_wfc = MAX ( lmax_wfc, MAXVAL (upf(nt)%lchi(1:upf(nt)%nwfc) ) )
enddo
DO nt = 1, ntyp
lmax_wfc = max ( lmax_wfc, maxval (upf(nt)%lchi(1:upf(nt)%nwfc) ) )
ENDDO
!
nwfcm = MAXVAL ( upf(1:ntyp)%nwfc )
nwfcm = maxval ( upf(1:ntyp)%nwfc )
!
allocate ( ylm (npw,(lmax_wfc+1)**2), chiq(npw,nwfcm,ntyp), &
ALLOCATE ( ylm (npw,(lmax_wfc+1)**2), chiq(npw,nwfcm,ntyp), &
sk(npw), gk(3,npw), qg(npw) )
!
do ig = 1, npw
DO ig = 1, npw
gk (1,ig) = xk(1, ik) + g(1, igk(ig) )
gk (2,ig) = xk(2, ik) + g(2, igk(ig) )
gk (3,ig) = xk(3, ik) + g(3, igk(ig) )
qg(ig) = gk(1, ig)**2 + gk(2, ig)**2 + gk(3, ig)**2
enddo
ENDDO
!
! ylm = spherical harmonics
!
call ylmr2 ((lmax_wfc+1)**2, npw, gk, qg, ylm)
CALL ylmr2 ((lmax_wfc+1)**2, npw, gk, qg, ylm)
!
! set now q=|k+G| in atomic units
!
do ig = 1, npw
DO ig = 1, npw
qg(ig) = sqrt(qg(ig))*tpiba
enddo
ENDDO
!
n_starting_wfc = 0
!
! chiq = radial fourier transform of atomic orbitals chi
!
do nt = 1, ntyp
do nb = 1, upf(nt)%nwfc
if ( upf(nt)%oc (nb) >= 0.d0) then
do ig = 1, npw
DO nt = 1, ntyp
DO nb = 1, upf(nt)%nwfc
IF ( upf(nt)%oc (nb) >= 0.d0) THEN
DO ig = 1, npw
px = qg (ig) / dq - int (qg (ig) / dq)
ux = 1.d0 - px
vx = 2.d0 - px
wx = 3.d0 - px
i0 = INT( qg (ig) / dq ) + 1
i0 = int( qg (ig) / dq ) + 1
i1 = i0 + 1
i2 = i0 + 2
i3 = i0 + 3
@ -92,29 +92,29 @@ SUBROUTINE atomic_wfc_nc_proj (ik, wfcatom)
tab_at (i1, nb, nt) * px * vx * wx / 2.d0 - &
tab_at (i2, nb, nt) * px * ux * wx / 2.d0 + &
tab_at (i3, nb, nt) * px * ux * vx / 6.d0
enddo
endif
enddo
enddo
ENDDO
ENDIF
ENDDO
ENDDO
deallocate (qg, gk)
allocate ( aux(npw) )
DEALLOCATE (qg, gk)
ALLOCATE ( aux(npw) )
do na = 1, nat
DO na = 1, nat
arg = (xk(1,ik)*tau(1,na) + xk(2,ik)*tau(2,na) + xk(3,ik)*tau(3,na)) * tpi
kphase = CMPLX(cos (arg), - sin (arg) ,kind=DP)
kphase = cmplx(cos (arg), - sin (arg) ,kind=DP)
!
! sk is the structure factor
!
do ig = 1, npw
DO ig = 1, npw
iig = igk (ig)
sk (ig) = kphase * eigts1 (ig1 (iig), na) * eigts2 (ig2 (iig), na) * &
eigts3 (ig3 (iig), na)
enddo
ENDDO
!
nt = ityp (na)
do nb = 1, upf(nt)%nwfc
if (upf(nt)%oc(nb) >= 0.d0) then
DO nb = 1, upf(nt)%nwfc
IF (upf(nt)%oc(nb) >= 0.d0) THEN
l = upf(nt)%lchi(nb)
lphase = (0.d0,1.d0)**l
!
@ -125,33 +125,33 @@ SUBROUTINE atomic_wfc_nc_proj (ik, wfcatom)
!
IF ( upf(nt)%has_so ) THEN
!
call atomic_wfc_so ( )
CALL atomic_wfc_so ( )
!
ELSE
!
call atomic_wfc_so2 ( )
CALL atomic_wfc_so2 ( )
!
ENDIF
!
ELSE
!
call atomic_wfc_nc_z ( )
CALL atomic_wfc_nc_z ( )
!
END IF
ENDIF
!
END IF
ENDIF
!
END DO
ENDDO
!
END DO
ENDDO
if (n_starting_wfc /= natomwfc) call errore ('atomic_wfc_nc_proj', &
IF (n_starting_wfc /= natomwfc) CALL errore ('atomic_wfc_nc_proj', &
'internal error: some wfcs were lost ', 1)
deallocate(aux, sk, chiq, ylm)
DEALLOCATE(aux, sk, chiq, ylm)
call stop_clock ('atomic_wfc')
return
CALL stop_clock ('atomic_wfc')
RETURN
CONTAINS
@ -160,16 +160,16 @@ CONTAINS
! ... spin-orbit case
!
real(DP) :: fact(2), j
real(DP), external :: spinor
integer :: ind, ind1, n1, is, sph_ind
real(DP), EXTERNAL :: spinor
INTEGER :: ind, ind1, n1, is, sph_ind
!
j = upf(nt)%jchi(nb)
do m = -l-1, l
DO m = -l-1, l
fact(1) = spinor(l,j,m,1)
fact(2) = spinor(l,j,m,2)
if (abs(fact(1)) > 1.d-8 .or. abs(fact(2)) > 1.d-8) then
IF (abs(fact(1)) > 1.d-8 .or. abs(fact(2)) > 1.d-8) THEN
n_starting_wfc = n_starting_wfc + 1
if (n_starting_wfc > natomwfc) call errore &
IF (n_starting_wfc > natomwfc) CALL errore &
('atomic_wfc_so', 'internal error: too many wfcs', 1)
DO is=1,2
IF (abs(fact(is)) > 1.d-8) THEN
@ -177,33 +177,33 @@ CONTAINS
aux=(0.d0,0.d0)
DO n1=1,2*l+1
ind1=l**2+n1
if (abs(rot_ylm(ind,n1)) > 1.d-8) &
IF (abs(rot_ylm(ind,n1)) > 1.d-8) &
aux(:)=aux(:)+rot_ylm(ind,n1)*ylm(:,ind1)
ENDDO
DO ig=1,npw
wfcatom (ig,is,n_starting_wfc) = lphase*fact(is)*&
sk(ig)*aux(ig)*chiq (ig, nb, nt)
END DO
ENDDO
ELSE
wfcatom (:,is,n_starting_wfc) = (0.d0,0.d0)
END IF
END DO
END IF
END DO
ENDIF
ENDDO
ENDIF
ENDDO
!
END SUBROUTINE atomic_wfc_so
!
!
SUBROUTINE atomic_wfc_so2 ( )
!
! ... spin-orbit case with no spin-orbit PP
!
real(DP) :: fact(2), j
real(DP), external :: spinor
integer :: ind, ind1, n1, n2, is, sph_ind
real(DP), EXTERNAL :: spinor
INTEGER :: ind, ind1, n1, n2, is, sph_ind
!
DO n2 = l, l + 1
j = n2 - 0.5_dp
IF (j > 0.0_dp) THEN
IF (j > 0.0_dp) THEN
DO m = -l-1, l
fact(1) = spinor(l,j,m,1)
fact(2) = spinor(l,j,m,2)
@ -227,9 +227,9 @@ CONTAINS
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
!
END SUBROUTINE atomic_wfc_so2
!
@ -240,11 +240,11 @@ CONTAINS
DO m = 1, 2 * l + 1
lm = l**2 + m
n_starting_wfc = n_starting_wfc + 1
if (n_starting_wfc + 2*l + 1 > natomwfc) call errore &
IF (n_starting_wfc + 2*l + 1 > natomwfc) CALL errore &
('atomic_wfc_nc', 'internal error: too many wfcs', 1)
DO ig=1,npw
aux(ig) = sk(ig)*ylm(ig,lm)*chiq(ig,nb,nt)
END DO
ENDDO
!
DO ig=1,npw
wfcatom(ig,1,n_starting_wfc) = aux(ig)
@ -252,8 +252,8 @@ CONTAINS
!
wfcatom(ig,1,n_starting_wfc+2*l+1) = (0.0_dp, 0.0_dp)
wfcatom(ig,2,n_starting_wfc+2*l+1) = aux(ig)
END DO
END DO
ENDDO
ENDDO
n_starting_wfc = n_starting_wfc + 2*l+1
!
END SUBROUTINE atomic_wfc_nc_z

96
PP/average.f90
View File

@ -11,14 +11,14 @@ PROGRAM average
!-----------------------------------------------------------------------
!
! This program calculates planar and macroscopic averages
! of a quantity defined on a 3D-FFT mesh.
! The planar average is done on FFT mesh planes.
! of a quantity defined on a 3D-FFT mesh.
! The planar average is done on FFT mesh planes.
! It reads the quantity to average, or several quantities, from
! one or several files and adds them with the given weights.
! It computes the planar average of the resulting quantity
! averaging on planes defined by the FFT mesh points and by one
! direction perpendicular to the planes.
! The planar average can be interpolated on a
! The planar average can be interpolated on a
! 1D-mesh with an arbitrary number of points.
! Finally, it computes the macroscopic average. The size
! of the averaging window is given as input.
@ -115,7 +115,7 @@ PROGRAM average
!
inunit = 5
READ (inunit, *, err = 1100, iostat = ios) nfile
IF (nfile.LE.0.OR.nfile.GT.nfilemax) CALL errore ('average ', &
IF (nfile<=0.or.nfile>nfilemax) CALL errore ('average ', &
'nfile is wrong ', 1)
DO ifile = 1, nfile
READ (inunit, '(a)', err = 1100, iostat = ios) filename (ifile)
@ -123,11 +123,11 @@ PROGRAM average
ENDDO
READ (inunit, *, err = 1100, iostat = ios) npt
IF (npt.LT.0.OR.npt.GT.npixmax) CALL errore ('average', ' wrong npt', 1)
IF (npt<0.or.npt>npixmax) CALL errore ('average', ' wrong npt', 1)
READ (inunit, *, err = 1100, iostat = ios) idir
READ (inunit, *, err = 1100, iostat = ios) awin
1100 CALL errore ('average', 'readin input', ABS (ios) )
1100 CALL errore ('average', 'readin input', abs (ios) )
CALL read_io_header(filename (1), title, nrx1, nrx2, nrx3, nr1, nr2, nr3, &
nat, ntyp, ibrav, celldm, at, gcutm, dual, ecutwfc, plot_num)
@ -140,26 +140,26 @@ PROGRAM average
tpiba = 2.d0 * pi / alat
tpiba2 = tpiba**2
IF (idir.EQ.1) THEN
IF (idir==1) THEN
nfft=nr1
nfftx=nrx1
leng=alat*SQRT(at(1,1)**2+at(2,1)**2+at(3,1)**2)
ELSEIF (idir.EQ.2) THEN
leng=alat*sqrt(at(1,1)**2+at(2,1)**2+at(3,1)**2)
ELSEIF (idir==2) THEN
nfft=nr2
nfftx=nrx2
leng=alat*SQRT(at(1,2)**2+at(2,2)**2+at(3,2)**2)
ELSEIF (idir.EQ.3) THEN
leng=alat*sqrt(at(1,2)**2+at(2,2)**2+at(3,2)**2)
ELSEIF (idir==3) THEN
nfft=nr3
nfftx=nrx3
leng=alat*SQRT(at(1,3)**2+at(2,3)**2+at(3,3)**2)
leng=alat*sqrt(at(1,3)**2+at(2,3)**2+at(3,3)**2)
ELSE
CALL errore('average','idir is wrong',1)
ENDIF
IF (npt.LT.nfft) CALL errore ('average', 'npt smaller than nfft', 1)
IF (npt<nfft) CALL errore ('average', 'npt smaller than nfft', 1)
ALLOCATE(tau (3, nat))
ALLOCATE(ityp(nat))
doublegrid = dual.GT.4.d0
doublegrid = dual>4.d0
IF (doublegrid) THEN
gcutms = 4.d0 * ecutwfc / tpiba2
ELSE
@ -169,7 +169,7 @@ PROGRAM average
! of a double grid, but the info on nrXs is not read from file!
nr1s = nr1 ; nr2s = nr2 ; nr3s = nr3
! as above: this can be used in allocate_fft
nks = 0
nks = 0
CALL volume (alat, at (1, 1), at (1, 2), at (1, 3), omega)
@ -186,7 +186,7 @@ PROGRAM average
plot_num, atm, ityp, zv, tau, rho%of_r, -1)
!
DO ir = 1, nrxx
psic (ir) = weight (1) * CMPLX(rho%of_r(ir, 1),0.d0,kind=DP)
psic (ir) = weight (1) * cmplx(rho%of_r(ir, 1),0.d0,kind=DP)
ENDDO
!
! Now we open all the other files
@ -197,8 +197,8 @@ PROGRAM average
! Note that only rho is read; all other quantities are discarded
!
DO ifile = 2, nfile
ALLOCATE (taus( 3 , nat))
ALLOCATE (ityps( nat))
ALLOCATE (taus( 3 , nat))
ALLOCATE (ityps( nat))
!
CALL plot_io (filename (ifile), title, nrx1sa, nrx2sa, nrx3sa, &
nr1sa, nr2sa, nr3sa, nats, ntyps, ibravs, celldms, ats, gcutmsa, &
@ -207,66 +207,66 @@ PROGRAM average
DEALLOCATE (ityps)
DEALLOCATE (taus)
!
IF (nats.GT.nat) CALL errore ('chdens', 'wrong file order? ', 1)
IF (nrx1.NE.nrx1sa.OR.nrx2.NE.nrx2sa) &
IF (nats>nat) CALL errore ('chdens', 'wrong file order? ', 1)
IF (nrx1/=nrx1sa.or.nrx2/=nrx2sa) &
CALL errore ('average', 'incompatible nrx1 or nrx2', 1)
IF (nr1.NE.nr1sa.OR.nr2.NE.nr2sa.OR.nr3.NE.nr3sa) &
IF (nr1/=nr1sa.or.nr2/=nr2sa.or.nr3/=nr3sa) &
CALL errore ('average', 'incompatible nr1 or nr2 or nr3', 1)
IF (ibravs.NE.ibrav) CALL errore ('average', 'incompatible ibrav', 1)
IF (gcutmsa.NE.gcutm.OR.duals.NE.dual.OR.ecuts.NE.ecutwfc ) &
IF (ibravs/=ibrav) CALL errore ('average', 'incompatible ibrav', 1)
IF (gcutmsa/=gcutm.or.duals/=dual.or.ecuts/=ecutwfc ) &
CALL errore ('average', 'incompatible gcutm or dual or ecut', 1)
DO i = 1, 6
IF (ABS( celldm (i)-celldms (i) ) .GT. 1.0d-7 ) &
IF (abs( celldm (i)-celldms (i) ) > 1.0d-7 ) &
CALL errore ('chdens', 'incompatible celldm', 1)
ENDDO
DO ir = 1, nrxx
psic (ir) = psic (ir) + weight(ifile) * CMPLX(rho%of_r(ir, 1),0.d0,kind=DP)
psic (ir) = psic (ir) + weight(ifile) * cmplx(rho%of_r(ir, 1),0.d0,kind=DP)
ENDDO
ENDDO
!
! compute the direct and reciprocal lattices
!
ALLOCATE (funcr(nfftx))
ALLOCATE (funci(nfftx))
ALLOCATE (funcr(nfftx))
ALLOCATE (funci(nfftx))
!
! At this point we start the calculations, first we compute the
! planar averages
!
IF (idir.EQ.1) THEN
IF (idir==1) THEN
DO i = 1, nr1
funcr (i) = 0.d0
funci (i) = 0.d0
DO j = 1, nr2
DO k = 1, nr3
ir = i + (j - 1) * nrx1 + (k - 1) * nrx1 * nrx2
funcr (i) = funcr (i) + DBLE (psic(ir))
funcr (i) = funcr (i) + dble (psic(ir))
ENDDO
ENDDO
funcr (i) = funcr (i) / (DBLE (nr2 * nr3))
funcr (i) = funcr (i) / (dble (nr2 * nr3))
ENDDO
ELSEIF (idir.EQ.2) THEN
ELSEIF (idir==2) THEN
DO j = 1, nr2
funcr (j) = 0.d0
funci (j) = 0.d0
DO i = 1, nr1
DO k = 1, nr3
ir = i + (j - 1) * nrx1 + (k - 1) * nrx1 * nrx2
funcr (j) = funcr (j) + DBLE (psic (ir) )
funcr (j) = funcr (j) + dble (psic (ir) )
ENDDO
ENDDO
funcr (j) = funcr (j) / (DBLE (nr1 * nr3) )
funcr (j) = funcr (j) / (dble (nr1 * nr3) )
ENDDO
ELSEIF (idir.EQ.3) THEN
ELSEIF (idir==3) THEN
DO k = 1, nr3
funcr (k) = 0.d0
funci (k) = 0.d0
DO j = 1, nr2
DO i = 1, nr1
ir = i + (j - 1) * nrx1 + (k - 1) * nrx1 * nrx2
funcr (k) = funcr (k) + DBLE (psic (ir) )
funcr (k) = funcr (k) + dble (psic (ir) )
ENDDO
ENDDO
funcr (k) = funcr (k) / (DBLE (nr1 * nr2) )
funcr (k) = funcr (k) / (dble (nr1 * nr2) )
ENDDO
ELSE
CALL errore('average','wrong idir',1)
@ -278,10 +278,10 @@ PROGRAM average
CALL dscal (nfft, 1.d0 / nfft, funcr, 1)
CALL dscal (nfft, 1.d0 / nfft, funci, 1)
DO k = 1, npt
IF (k.LE.nfft / 2) THEN
IF (k<=nfft / 2) THEN
gre (k) = funcr (k)
gim (k) = funci (k)
ELSEIF (k.GT.npt - nfft / 2) THEN
ELSEIF (k>npt - nfft / 2) THEN
gre (k) = funcr (k - npt + nfft)
gim (k) = funci (k - npt + nfft)
ELSE
@ -289,7 +289,7 @@ PROGRAM average
gim (k) = 0.d0
ENDIF
ENDDO
IF (MOD (nfft, 2) .EQ.0) THEN
IF (mod (nfft, 2) ==0) THEN
gre (nfft / 2 + 1) = 0.5d0 * funcr (nfft / 2 + 1)
gim (nfft / 2 + 1) = 0.5d0 * funci (nfft / 2 + 1)
gre (npt - nfft / 2 + 1) = gre (nfft / 2 + 1)
@ -305,26 +305,26 @@ PROGRAM average
! compute the macroscopic average
!
nmacro = npt * (awin / leng )
IF (nmacro.LE.0) CALL errore ('average ', 'nmacro is too small ', 1)
IF (nmacro<=0) CALL errore ('average ', 'nmacro is too small ', 1)
DO i = 1, npt
macros (i) = 0.d0
DO j = - nmacro / 2, nmacro / 2
k = i + j
IF (k.LE.0) k = k + npt
IF (k.GT.npt) k = k - npt
IF (k<=0) k = k + npt
IF (k>npt) k = k - npt
if ( (2*j==nmacro) .or. (2*j==-nmacro) ) then
IF ( (2*j==nmacro) .or. (2*j==-nmacro) ) THEN
macros (i) = macros (i) + 0.5d0 * gre(k)
else
ELSE
macros (i) = macros (i) + gre (k)
end if
ENDIF
ENDDO
macros (i) = macros (i) / DBLE (nmacro)
macros (i) = macros (i) / dble (nmacro)
ENDDO
!
! print the results on output
!
deltaz = leng / DBLE (npt)
deltaz = leng / dble (npt)
WRITE( stdout, '(3f15.9)') (deltaz * (i - 1) , gre (i) , macros (i) , &
@ -332,7 +332,7 @@ PROGRAM average
DEALLOCATE(funci)
DEALLOCATE(funcr)
!
END IF
ENDIF
!
CALL stop_pp
!

134
PP/bands.f90
View File

@ -30,7 +30,7 @@ PROGRAM bands
!
NAMELIST / inputpp / outdir, prefix, filband, filp, spin_component, lsigma,&
lsym, lp, filp, firstk, lastk, no_overlap
!
!
! initialise environment
!
#ifdef __PARA
@ -42,7 +42,7 @@ PROGRAM bands
!
prefix = 'pwscf'
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
IF ( trim( outdir ) == ' ' ) outdir = './'
filband = 'bands.out'
lsym=.false.
lsigma=.false.
@ -64,11 +64,11 @@ PROGRAM bands
lsigma(4)=.false.
tmp_dir = trimcheck (outdir)
!
END IF
ENDIF
!
!
CALL mp_bcast( ios, ionode_id )
IF (ios /= 0) CALL errore ('do_bands', 'reading inputpp namelist', ABS(ios) )
IF (ios /= 0) CALL errore ('do_bands', 'reading inputpp namelist', abs(ios) )
!
! ... Broadcast variables
!
@ -152,7 +152,7 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
COMPLEX(DP), ALLOCATABLE :: psiold (:,:), old (:), new (:)
! psiold: eigenfunctions at previous k-point, ordered
! old, new: contain one band resp. at previous and current k-point
TYPE(bec_type):: becp, becpold
TYPE(bec_type):: becp, becpold
! becp : <psi|beta> at current k-point
! becpold: <psi|beta> at previous k-point
COMPLEX(DP), ALLOCATABLE :: psiold_nc (:,:), old_nc(:,:), new_nc(:,:)
@ -165,19 +165,19 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
! ok: keeps track of which bands have been already ordered
! igkold: indices of k+G at previous k-point
! il: band ordering
INTEGER :: maxdeg
INTEGER :: maxdeg
! maxdeg : max allowed degeneracy
INTEGER :: ndeg, deg, nd
! ndeg : number of degenerate states
INTEGER, ALLOCATABLE :: degeneracy(:), degbands(:,:), idx(:)
! degbands keeps track of which states are degenerate
INTEGER :: iunpun_sigma(4), ios(0:4), indjbnd
CHARACTER(LEN=256) :: nomefile
CHARACTER(len=256) :: nomefile
REAL(DP), ALLOCATABLE:: edeg(:)
REAL(DP), ALLOCATABLE:: sigma_avg(:,:,:)
! expectation value of sigma
REAL(DP), PARAMETER :: eps = 0.00001d0
! threshold (Ry) for degenerate states
! threshold (Ry) for degenerate states
REAL(DP) :: minene
COMPLEX(DP), EXTERNAL :: cgracsc, cgracsc_nc
! scalar product with the S matrix
@ -190,10 +190,10 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
lsigma=.false.
ENDIF
ENDDO
iunpun = 18
maxdeg = 30 * npol
!
maxdeg = 30 * npol
!
ios(:) = 0
IF ( ionode ) THEN
!
@ -205,21 +205,21 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
iunpun_sigma(ipol)=iunpun+ipol
WRITE(nomefile,'(".",i1)') ipol
OPEN (unit = iunpun_sigma(ipol), &
file = TRIM(filband)//TRIM(nomefile), &
file = trim(filband)//trim(nomefile), &
status = 'unknown', form='formatted', iostat = ios(ipol))
REWIND (iunpun_sigma(ipol))
ENDIF
ENDDO
!
END IF
ENDIF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios(0) /= 0 ) &
CALL errore ('punch_band', 'Opening filband file', ABS(ios(0)) )
CALL errore ('punch_band', 'Opening filband file', abs(ios(0)) )
DO ipol=1,4
IF ( ios(ipol) /= 0 ) &
CALL errore ('punch_band', 'Opening filband.N file ', ipol)
END DO
ENDDO
!
CALL allocate_bec_type(nkb, nbnd, becp)
CALL allocate_bec_type(nkb, nbnd, becpold)
@ -228,18 +228,18 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
ALLOCATE (old_nc(ngm,npol), new_nc(ngm,npol))
ALLOCATE (sigma_avg(4,nbnd,nkstot))
ELSE
ALLOCATE (psiold( npwx, nbnd))
ALLOCATE (old(ngm), new(ngm))
END IF
ALLOCATE (psiold( npwx, nbnd))
ALLOCATE (old(ngm), new(ngm))
ENDIF
ALLOCATE (igkold (npwx))
ALLOCATE (igkold (npwx))
ALLOCATE (ok (nbnd), il (nbnd,nkstot), ilold(nbnd) )
ALLOCATE (degeneracy(nbnd), edeg(nbnd))
ALLOCATE (idx(nbnd), degbands(nbnd,maxdeg))
!
IF (spin_component.NE.1.AND.nspin.NE.2) &
IF (spin_component/=1.and.nspin/=2) &
CALL errore('punch_bands','incorrect spin_component',1)
IF (spin_component<1.OR.spin_component>2) &
IF (spin_component<1.or.spin_component>2) &
CALL errore('punch_bands','incorrect lsda spin_component',1)
CALL find_nks1nks2(1,nkstot,nks1tot,nks1,nks2tot,nks2,spin_component)
@ -248,14 +248,14 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
DO ik=nks1,nks2
DO ibnd = 1, nbnd
il (ibnd,ik) = ibnd
END DO
END DO
ENDDO
ENDDO
DO ik = nks1, nks2
!
! prepare the indices of this k point
!
IF (.NOT.no_overlap.OR.lsigma(1).OR.lsigma(2).OR.lsigma(3).OR.lsigma(4)) THEN
IF (.not.no_overlap.or.lsigma(1).or.lsigma(2).or.lsigma(3).or.lsigma(4)) THEN
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, &
igk, g2kin)
!
@ -263,13 +263,13 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
!
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
!
! calculate becp = <psi|beta>
!
! calculate becp = <psi|beta>
!
CALL init_us_2 (npw, igk, xk (1, ik), vkb)
CALL calbec ( npw, vkb, evc, becp )
IF (noncolin) &
CALL compute_sigma_avg(sigma_avg(1,1,ik),becp%nc,ik,lsigma)
END IF
ENDIF
!
IF (ik==nks1.or.no_overlap) THEN
!
@ -278,7 +278,7 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
!
DO ibnd = 1, nbnd
il (ibnd,ik) = ibnd
END DO
ENDDO
ELSE
!
! following k-points in the list:
@ -301,13 +301,13 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
DO ig = 1, npwold
old_nc(igkold(ig), 1)=psiold_nc(ig ,idx(ibnd))
old_nc(igkold(ig), 2)=psiold_nc(ig+npwx,idx(ibnd))
END DO
ENDDO
ELSE
old = (0.d0, 0.d0)
DO ig = 1, npwold
old (igkold (ig) ) = psiold (ig, idx(ibnd))
END DO
END IF
ENDDO
ENDIF
DO jbnd = 1, nbnd
IF (ok (jbnd) == 0) THEN
IF (noncolin) THEN
@ -315,7 +315,7 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
DO ig = 1, npw
new_nc (igk (ig), 1) = evc (ig , jbnd)
new_nc (igk (ig), 2) = evc (ig+npwx, jbnd)
END DO
ENDDO
pro = cgracsc_nc (nkb,becp%nc(1,1,jbnd), &
becpold%nc(1,1,idx(ibnd)), nhm, ntyp, nh, &
nat, ityp, ngm, npol, new_nc, old_nc, upf)
@ -323,22 +323,22 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
new (:) = (0.d0, 0.d0)
DO ig = 1, npw
new (igk (ig) ) = evc (ig, jbnd)
END DO
ENDDO
pro=cgracsc(nkb,becp%k(1,jbnd),becpold%k(1,idx(ibnd)), &
nhm, ntyp, nh, qq, nat, ityp, ngm, NEW, old, upf)
END IF
ENDIF
! write(6,'(3i5,f15.10)') ik,idx(ibnd), jbnd, abs(pro)
IF (abs (pro) > 1.d-2 ) THEN
il (idx(ibnd),ik) = jbnd
GOTO 10
END IF
END IF
END DO
ENDIF
ENDIF
ENDDO
! WRITE(6,*) ' no band found', ik, ilold(idx(ibnd)), &
! et(ilold(idx(ibnd)),ik-1)*rytoev
!
! no band found. Takes the closest in energy. NB: This should happen only
! for high energy bands.
! for high energy bands.
!
minene=1.d10
DO jbnd = 1, nbnd
@ -352,7 +352,7 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
il(idx(ibnd),ik)=indjbnd
10 CONTINUE
ok (il (idx(ibnd),ik) ) = 1
END DO
ENDDO
!
! if there were bands crossing at degenerate eigenvalues
! at previous k-point, re-order those bands so as to keep
@ -362,35 +362,35 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
DO deg = 1, degeneracy (nd)
idx(deg) = il(degbands(nd,deg),ik)
edeg (deg) = et(il(degbands(nd,deg),ik), ik)
END DO
ENDDO
CALL hpsort(degeneracy (nd), edeg, idx)
DO deg = 1, degeneracy (nd)
il(degbands(nd,deg),ik) = idx(deg)
END DO
END DO
END IF
ENDDO
ENDDO
ENDIF
!
! Now the order of eigenfunctions has been established
! for this k-point -- prepare data for next k point
!
IF (.NOT.no_overlap.OR.lsigma(1).OR.lsigma(2).OR.lsigma(3).OR.lsigma(4)) THEN
IF (.not.no_overlap.or.lsigma(1).or.lsigma(2).or.lsigma(3).or.lsigma(4)) THEN
DO ibnd = 1, nbnd
IF (noncolin) THEN
psiold_nc(:,ibnd) = evc(:,il(ibnd,ik))
DO ipol=1,npol
DO ikb = 1, nkb
becpold%nc(ikb, ipol, ibnd)=becp%nc(ikb,ipol,il(ibnd,ik))
END DO
END DO
ENDDO
ENDDO
ELSE
DO ig = 1, npw
psiold (ig, ibnd) = evc (ig, il (ibnd,ik) )
END DO
ENDDO
DO ikb = 1, nkb
becpold%k (ikb, ibnd) = becp%k (ikb, il (ibnd,ik) )
END DO
END IF
END DO
ENDDO
ENDIF
ENDDO
DO ig = 1, npw
igkold (ig) = igk (ig)
ENDDO
@ -402,33 +402,33 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
deg = 0
ndeg = 0
DO ibnd = 2, nbnd
IF ( ABS (et(ibnd, ik) - et(ibnd-1, ik)) < eps ) THEN
IF ( abs (et(ibnd, ik) - et(ibnd-1, ik)) < eps ) THEN
IF ( deg == 0 ) THEN
ndeg = ndeg + 1
edeg (ndeg) = et(ibnd, ik)
END IF
ENDIF
deg = 1
ELSE
deg = 0
END IF
END DO
ENDIF
ENDDO
!
! locate band crossings at degenerate eigenvalues
!
DO nd = 1, ndeg
deg = 0
DO ibnd = 1, nbnd
IF ( ABS (et(il(ibnd,ik), ik) - edeg (nd)) < eps ) THEN
IF ( abs (et(il(ibnd,ik), ik) - edeg (nd)) < eps ) THEN
deg = deg + 1
IF (deg > maxdeg) CALL errore ('punch_band', &
' increase maxdeg', deg)
degbands(nd,deg) = ibnd
END IF
END DO
ENDIF
ENDDO
degeneracy (nd) = deg
END DO
END IF
END DO
ENDDO
ENDIF
ENDDO
#ifdef __PARA
IF (noncolin) CALL poolrecover(sigma_avg,4*nbnd,nkstot,nks)
CALL ipoolrecover(il,nbnd,nkstot,nks)
@ -444,8 +444,8 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
IF (lsigma(ipol)) WRITE(iunpun_sigma(ipol), &
'(" &plot nbnd=",i4,", nks=",i4," /")') &
nbnd, nks2tot-nks1tot+1
END DO
END IF
ENDDO
ENDIF
WRITE (iunpun, '(10x,3f10.6)') xk(1,ik),xk(2,ik),xk(3,ik)
WRITE (iunpun, '(10f8.3)') (et (il(ibnd,ik), ik) &
* rytoev, ibnd = 1, nbnd)
@ -455,11 +455,11 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
xk(1,ik),xk(2,ik),xk(3,ik)
WRITE (iunpun_sigma(ipol), '(10f8.3)') &
(sigma_avg(ipol, il(ibnd,ik) , ik), ibnd = 1, nbnd)
END IF
END DO
ENDIF
ENDDO
!
END DO
END IF
ENDDO
ENDIF
!
DEALLOCATE (idx, degbands)
DEALLOCATE (edeg, degeneracy)
@ -474,7 +474,7 @@ SUBROUTINE punch_band (filband, spin_component, lsigma, no_overlap)
ELSE
DEALLOCATE (new, old)
DEALLOCATE (psiold)
END IF
ENDIF
!
IF ( ionode ) THEN
CLOSE (iunpun)

222
PP/cft.f90
View File

@ -1,14 +1,14 @@
!
! (C) Copyright CERN except where explicitly stated otherwise.
! (C) Copyright CERN except where explicitly stated otherwise.
! Permission to use and/or redistribute this work is granted
! under the terms of the GNU General Public License, The software
! and documentation made available under the terms of this license
! are provided with no warranty.
! are provided with no warranty.
!
! Slightly modified version of routine D702 of CERN lib
!
!----------------------------------------------------------------------
subroutine cft (a, b, ntot, n, nspan, isn)
SUBROUTINE cft (a, b, ntot, n, nspan, isn)
!----------------------------------------------------------------------
!
! multivariate complex fourier transform, computed in place
@ -63,16 +63,16 @@ subroutine cft (a, b, ntot, n, nspan, isn)
! square-free factors must be .le. 210
!
USE kinds
implicit real(DP)(a - h, o - z)
dimension a ( * ), b ( * )
dimension nfac (11), np (209)
IMPLICIT real(DP)(a - h, o - z)
DIMENSION a ( * ), b ( * )
DIMENSION nfac (11), np (209)
! array storage for maximum prime factor of 23
dimension at (23), ck (23), bt (23), sk (23)
equivalence (i, ii)
DIMENSION at (23), ck (23), bt (23), sk (23)
EQUIVALENCE (i, ii)
! the following two constants should agree with the array dimension
maxf = 23
maxp = 209
if (n.lt.2) return
IF (n<2) RETURN
inc = isn
! the following constants are rad = 2.*pi , s72 = sin(0.4*pi) ,
! c72 = cos(0.4*pi) and s120 = sqrt(0.75)
@ -80,7 +80,7 @@ subroutine cft (a, b, ntot, n, nspan, isn)
s72 = 0.95105651629515d0
c72 = 0.30901699437495d0
s120 = 0.86602540378444d0
if (isn.ge.0) goto 10
IF (isn>=0) GOTO 10
s72 = - s72
s120 = - s120
rad = - rad
@ -90,57 +90,57 @@ subroutine cft (a, b, ntot, n, nspan, isn)
kspan = ks
nn = nt - inc
jc = ks / n
radf = rad * DBLE (jc) * 0.5d0
radf = rad * dble (jc) * 0.5d0
i = 0
jf = 0
! determine the factors of n
m = 0
k = n
goto 20
GOTO 20
15 m = m + 1
nfac (m) = 4
k = k / 16
20 if (k - (k / 16) * 16.eq.0) goto 15
20 IF (k - (k / 16) * 16==0) GOTO 15
j = 3
jj = 9
goto 30
GOTO 30
25 m = m + 1
nfac (m) = j
k = k / jj
30 if (mod (k, jj) .eq.0) goto 25
30 IF (mod (k, jj) ==0) GOTO 25
j = j + 2
jj = j**2
if (jj.le.k) goto 30
if (k.gt.4) goto 40
IF (jj<=k) GOTO 30
IF (k>4) GOTO 40
kt = m
nfac (m + 1) = k
if (k.ne.1) m = m + 1
goto 80
40 if (k - (k / 4) * 4.ne.0) goto 50
IF (k/=1) m = m + 1
GOTO 80
40 IF (k - (k / 4) * 4/=0) GOTO 50
m = m + 1
nfac (m) = 2
k = k / 4
50 kt = m
j = 2
60 if (mod (k, j) .ne.0) goto 70
60 IF (mod (k, j) /=0) GOTO 70
m = m + 1
nfac (m) = j
k = k / j
70 j = ( (j + 1) / 2) * 2 + 1
if (j.le.k) goto 60
80 if (kt.eq.0) goto 100
IF (j<=k) GOTO 60
80 IF (kt==0) GOTO 100
j = kt
90 m = m + 1
nfac (m) = nfac (j)
j = j - 1
if (j.ne.0) goto 90
IF (j/=0) GOTO 90
! compute fourier transform
100 sd = radf / DBLE (kspan)
100 sd = radf / dble (kspan)
cd = 2.0d0 * sin (sd) **2
sd = sin (sd+sd)
kk = 1
i = i + 1
if (nfac (i) .ne.2) goto 400
IF (nfac (i) /=2) GOTO 400
! transform for factor of 2 (including rotation factor)
kspan = kspan / 2
k1 = kspan + 2
@ -152,10 +152,10 @@ subroutine cft (a, b, ntot, n, nspan, isn)
a (kk) = a (kk) + ak
b (kk) = b (kk) + bk
kk = k2 + kspan
if (kk.le.nn) goto 210
IF (kk<=nn) GOTO 210
kk = kk - nn
if (kk.le.jc) goto 210
if (kk.gt.kspan) goto 800
IF (kk<=jc) GOTO 210
IF (kk>kspan) GOTO 800
220 c1 = 1.0d0 - cd
s1 = sd
230 k2 = kk + kspan
@ -166,11 +166,11 @@ subroutine cft (a, b, ntot, n, nspan, isn)
a (k2) = c1 * ak - s1 * bk
b (k2) = s1 * ak + c1 * bk
kk = k2 + kspan
if (kk.lt.nt) goto 230
IF (kk<nt) GOTO 230
k2 = kk - nt
c1 = - c1
kk = k1 - k2
if (kk.gt.k2) goto 230
IF (kk>k2) GOTO 230
ak = c1 - (cd * c1 + sd * s1)
s1 = (sd * c1 - cd * s1) + s1
! the following three statements compensate for truncation
@ -181,11 +181,11 @@ subroutine cft (a, b, ntot, n, nspan, isn)
! next statement should be deleted if non-rounded arithmetic is use
! c1=ak
kk = kk + jc
if (kk.lt.k2) goto 230
IF (kk<k2) GOTO 230
k1 = k1 + inc + inc
kk = (k1 - kspan) / 2 + jc
if (kk.le.jc + jc) goto 220
goto 100
IF (kk<=jc + jc) GOTO 220
GOTO 100
! transform for factor of 3 (optional code)
320 k1 = kk + kspan
k2 = k1 + kspan
@ -204,12 +204,12 @@ subroutine cft (a, b, ntot, n, nspan, isn)
a (k2) = ak + bj
b (k2) = bk - aj
kk = k2 + kspan
if (kk.lt.nn) goto 320
IF (kk<nn) GOTO 320
kk = kk - nn
if (kk.le.kspan) goto 320
goto 700
IF (kk<=kspan) GOTO 320
GOTO 700
! transform for factor of 4
400 if (nfac (i) .ne.4) goto 600
400 IF (nfac (i) /=4) GOTO 600
kspnn = kspan
kspan = kspan / 4
410 c1 = 1.0d0
@ -229,12 +229,12 @@ subroutine cft (a, b, ntot, n, nspan, isn)
bjm = b (k1) - b (k3)
b (kk) = bkp + bjp
bjp = bkp - bjp
if (isn.lt.0) goto 450
IF (isn<0) GOTO 450
akp = akm - bjm
akm = akm + bjm
bkp = bkm + ajm
bkm = bkm - ajm
if (s1.eq.0.0d0) goto 460
IF (s1==0.0d0) GOTO 460
430 a (k1) = akp * c1 - bkp * s1
b (k1) = akp * s1 + bkp * c1
a (k2) = ajp * c2 - bjp * s2
@ -242,7 +242,7 @@ subroutine cft (a, b, ntot, n, nspan, isn)
a (k3) = akm * c3 - bkm * s3
b (k3) = akm * s3 + bkm * c3
kk = k3 + kspan
if (kk.le.nt) goto 420
IF (kk<=nt) GOTO 420
440 c2 = c1 - (cd * c1 + sd * s1)
s1 = (sd * c1 - cd * s1) + s1
! the following three statements compensate for truncation
@ -257,16 +257,16 @@ subroutine cft (a, b, ntot, n, nspan, isn)
c3 = c2 * c1 - s2 * s1
s3 = c2 * s1 + s2 * c1
kk = kk - nt + jc
if (kk.le.kspan) goto 420
IF (kk<=kspan) GOTO 420
kk = kk - kspan + inc
if (kk.le.jc) goto 410
if (kspan.eq.jc) goto 800
goto 100
IF (kk<=jc) GOTO 410
IF (kspan==jc) GOTO 800
GOTO 100
450 akp = akm + bjm
akm = akm - bjm
bkp = bkm - ajm
bkm = bkm + ajm
if (s1.ne.0.0) goto 430
IF (s1/=0.0) GOTO 430
460 a (k1) = akp
b (k1) = bkp
a (k2) = ajp
@ -274,8 +274,8 @@ subroutine cft (a, b, ntot, n, nspan, isn)
a (k3) = akm
b (k3) = bkm
kk = k3 + kspan
if (kk.le.nt) goto 420
goto 440
IF (kk<=nt) GOTO 420
GOTO 440
! transform for factor of 5 (optional code)
510 c2 = c72**2 - s72**2
s2 = 2.0d0 * c72 * s72
@ -312,22 +312,22 @@ subroutine cft (a, b, ntot, n, nspan, isn)
b (k2) = bk + aj
b (k3) = bk - aj
kk = k4 + kspan
if (kk.lt.nn) goto 520
IF (kk<nn) GOTO 520
kk = kk - nn
if (kk.le.kspan) goto 520
goto 700
IF (kk<=kspan) GOTO 520
GOTO 700
! transform for odd factors
600 k = nfac (i)
kspnn = kspan
kspan = kspan / k
if (k.eq.3) goto 320
if (k.eq.5) goto 510
if (k.eq.jf) goto 640
IF (k==3) GOTO 320
IF (k==5) GOTO 510
IF (k==jf) GOTO 640
jf = k
s1 = rad / DBLE (k)
s1 = rad / dble (k)
c1 = cos (s1)
s1 = sin (s1)
if (jf.gt.maxf) goto 998
IF (jf>maxf) GOTO 998
ck (jf) = 1.0d0
sk (jf) = 0.0d0
j = 1
@ -337,7 +337,7 @@ subroutine cft (a, b, ntot, n, nspan, isn)
ck (k) = ck (j)
sk (k) = - sk (j)
j = j + 1
if (j.lt.k) goto 630
IF (j<k) GOTO 630
640 k1 = kk
k2 = kk + kspnn
aa = a (kk)
@ -356,7 +356,7 @@ subroutine cft (a, b, ntot, n, nspan, isn)
at (j) = a (k1) - a (k2)
bt (j) = b (k1) - b (k2)
k1 = k1 + kspan
if (k1.lt.k2) goto 650
IF (k1<k2) GOTO 650
a (kk) = ak
b (kk) = bk
k1 = kk
@ -377,21 +377,21 @@ subroutine cft (a, b, ntot, n, nspan, isn)
aj = at (k) * sk (jj) + aj
bj = bt (k) * sk (jj) + bj
jj = jj + j
if (jj.gt.jf) jj = jj - jf
if (k.lt.jf) goto 670
IF (jj>jf) jj = jj - jf
IF (k<jf) GOTO 670
k = jf - j
a (k1) = ak - bj
b (k1) = bk + aj
a (k2) = ak + bj
b (k2) = bk - aj
j = j + 1
if (j.lt.k) goto 660
IF (j<k) GOTO 660
kk = kk + kspnn
if (kk.le.nn) goto 640
IF (kk<=nn) GOTO 640
kk = kk - nn
if (kk.le.kspan) goto 640
IF (kk<=kspan) GOTO 640
! multiply by rotation factor (except for factors of 2 and 4)
700 if (i.eq.m) goto 800
700 IF (i==m) GOTO 800
kk = jc + 1
710 c2 = 1.0d0 - cd
s1 = sd
@ -402,12 +402,12 @@ subroutine cft (a, b, ntot, n, nspan, isn)
a (kk) = c2 * ak - s2 * b (kk)
b (kk) = s2 * ak + c2 * b (kk)
kk = kk + kspnn
if (kk.le.nt) goto 730
IF (kk<=nt) GOTO 730
ak = s1 * s2
s2 = s1 * c2 + c1 * s2
c2 = c1 * c2 - ak
kk = kk - nt + kspan
if (kk.le.kspnn) goto 730
IF (kk<=kspnn) GOTO 730
c2 = c1 - (cd * c1 + sd * s1)
s1 = s1 + (sd * c1 - cd * s1)
! the following three statements compensate for truncation
@ -417,29 +417,29 @@ subroutine cft (a, b, ntot, n, nspan, isn)
s1 = c1 * s1
c2 = c1 * c2
kk = kk - kspnn + jc
if (kk.le.kspan) goto 720
IF (kk<=kspan) GOTO 720
kk = kk - kspan + jc + inc
if (kk.le.jc + jc) goto 710
goto 100
IF (kk<=jc + jc) GOTO 710
GOTO 100
! permute the results to normal order---done in two stages
! permutation for square factors of n
800 np (1) = ks
if (kt.eq.0) goto 890
IF (kt==0) GOTO 890
k = kt + kt + 1
if (m.lt.k) k = k - 1
IF (m<k) k = k - 1
j = 1
np (k + 1) = jc
810 np (j + 1) = np (j) / nfac (j)
np (k) = np (k + 1) * nfac (j)
j = j + 1
k = k - 1
if (j.lt.k) goto 810
IF (j<k) GOTO 810
k3 = np (k + 1)
kspan = np (2)
kk = jc + 1
k2 = kspan + 1
j = 1
if (n.ne.ntot) goto 850
IF (n/=ntot) GOTO 850
! permutation for single-variate transform (optional code)
820 ak = a (kk)
a (kk) = a (k2)
@ -449,19 +449,19 @@ subroutine cft (a, b, ntot, n, nspan, isn)
b (k2) = bk
kk = kk + inc
k2 = kspan + k2
if (k2.lt.ks) goto 820
IF (k2<ks) GOTO 820
830 k2 = k2 - np (j)
j = j + 1
k2 = np (j + 1) + k2
if (k2.gt.np (j) ) goto 830
IF (k2>np (j) ) GOTO 830
j = 1
840 if (kk.lt.k2) goto 820
840 IF (kk<k2) GOTO 820
kk = kk + inc
k2 = kspan + k2
if (k2.lt.ks) goto 840
if (kk.lt.ks) goto 830
IF (k2<ks) GOTO 840
IF (kk<ks) GOTO 830
jc = k3
goto 890
GOTO 890
! permutation for multivariate transform
850 k = kk + jc
860 ak = a (kk)
@ -472,72 +472,72 @@ subroutine cft (a, b, ntot, n, nspan, isn)
b (k2) = bk
kk = kk + inc
k2 = k2 + inc
if (kk.lt.k) goto 860
IF (kk<k) GOTO 860
kk = kk + ks - jc
k2 = k2 + ks - jc
if (kk.lt.nt) goto 850
IF (kk<nt) GOTO 850
k2 = k2 - nt + kspan
kk = kk - nt + jc
if (k2.lt.ks) goto 850
IF (k2<ks) GOTO 850
870 k2 = k2 - np (j)
j = j + 1
k2 = np (j + 1) + k2
if (k2.gt.np (j) ) goto 870
IF (k2>np (j) ) GOTO 870
j = 1
880 if (kk.lt.k2) goto 850
880 IF (kk<k2) GOTO 850
kk = kk + jc
k2 = kspan + k2
if (k2.lt.ks) goto 880
if (kk.lt.ks) goto 870
IF (k2<ks) GOTO 880
IF (kk<ks) GOTO 870
jc = k3
890 if (2 * kt + 1.ge.m) return
890 IF (2 * kt + 1>=m) RETURN
kspnn = np (kt + 1)
! permutation for square-free factors of n
j = m - kt
nfac (j + 1) = 1
900 nfac (j) = nfac (j) * nfac (j + 1)
j = j - 1
if (j.ne.kt) goto 900
IF (j/=kt) GOTO 900
kt = kt + 1
nn = nfac (kt) - 1
if (nn.gt.maxp) goto 998
IF (nn>maxp) GOTO 998
jj = 0
j = 0
goto 906
GOTO 906
902 jj = jj - k2
k2 = kk
k = k + 1
kk = nfac (k)
904 jj = kk + jj
if (jj.ge.k2) goto 902
IF (jj>=k2) GOTO 902
np (j) = jj
906 k2 = nfac (kt)
k = kt + 1
kk = nfac (k)
j = j + 1
if (j.le.nn) goto 904
IF (j<=nn) GOTO 904
! determine the permutation cycles of length greater than 1
j = 0
goto 914
GOTO 914
910 k = kk
kk = np (k)
np (k) = - kk
if (kk.ne.j) goto 910
IF (kk/=j) GOTO 910
k3 = kk
914 j = j + 1
kk = np (j)
if (kk.lt.0) goto 914
if (kk.ne.j) goto 910
IF (kk<0) GOTO 914
IF (kk/=j) GOTO 910
np (j) = - j
if (j.ne.nn) goto 914
IF (j/=nn) GOTO 914
maxf = inc * maxf
! reorder a and b, following the permutation cycles
goto 950
GOTO 950
924 j = j - 1
if (np (j) .lt.0) goto 924
IF (np (j) <0) GOTO 924
jj = jc
926 kspan = jj
if (jj.gt.maxf) kspan = maxf
IF (jj>maxf) kspan = maxf
jj = jj - kspan
k = np (j)
kk = jc * k + ii + jj
@ -547,7 +547,7 @@ subroutine cft (a, b, ntot, n, nspan, isn)
at (k2) = a (k1)
bt (k2) = b (k1)
k1 = k1 - inc
if (k1.ne.kk) goto 928
IF (k1/=kk) GOTO 928
932 k1 = kk + kspan
k2 = k1 - jc * (k + np (k) )
k = - np (k)
@ -555,27 +555,27 @@ subroutine cft (a, b, ntot, n, nspan, isn)
b (k1) = b (k2)
k1 = k1 - inc
k2 = k2 - inc
if (k1.ne.kk) goto 936
IF (k1/=kk) GOTO 936
kk = k2
if (k.ne.j) goto 932
IF (k/=j) GOTO 932
k1 = kk + kspan
k2 = 0
940 k2 = k2 + 1
a (k1) = at (k2)
b (k1) = bt (k2)
k1 = k1 - inc
if (k1.ne.kk) goto 940
if (jj.ne.0) goto 926
if (j.ne.1) goto 924
IF (k1/=kk) GOTO 940
IF (jj/=0) GOTO 926
IF (j/=1) GOTO 924
950 j = k3 + 1
nt = nt - kspnn
ii = nt - inc + 1
if (nt.ge.0) goto 924
return
IF (nt>=0) GOTO 924
RETURN
! error finish, insufficient array storage
998 isn = 0
! print 999
print*,'Array bounds exceeded within subroutine cft'
stop
PRINT*,'Array bounds exceeded within subroutine cft'
STOP
!999 format(44h0array bounds exceeded within subroutine cft)
end subroutine cft
END SUBROUTINE cft

130
PP/cgracsc.f90
View File

@ -7,7 +7,7 @@
!
!
!-----------------------------------------------------------------------
function cgracsc (nkb, bec1, bec2, nhm, ntyp, nh, qq, nat, ityp, &
FUNCTION cgracsc (nkb, bec1, bec2, nhm, ntyp, nh, qq, nat, ityp, &
npw, psi1, psi2, upf)
!-----------------------------------------------------------------------
!
@ -18,17 +18,17 @@ function cgracsc (nkb, bec1, bec2, nhm, ntyp, nh, qq, nat, ityp, &
!
!
USE kinds
USE pseudo_types, ONLY : pseudo_upf
USE pseudo_types, ONLY : pseudo_upf
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
implicit none
IMPLICIT NONE
!
! here the dummy variables
!
integer :: nkb, npw, nhm, ntyp, nat, ityp (nat), nh (ntyp)
INTEGER :: nkb, npw, nhm, ntyp, nat, ityp (nat), nh (ntyp)
! input: the number of beta functions
! input: the number of plane waves
! input: the maximum number of solid be
@ -37,7 +37,7 @@ function cgracsc (nkb, bec1, bec2, nhm, ntyp, nh, qq, nat, ityp, &
! input: the type of each atom
! input: the number of beta for each ty
complex(DP) :: bec1 (nkb), bec2 (nkb), psi1 (npw), psi2 (npw), &
COMPLEX(DP) :: bec1 (nkb), bec2 (nkb), psi1 (npw), psi2 (npw), &
cgracsc
! input: the product of beta and psi1
! input: the product of beta and psi2
@ -47,13 +47,13 @@ function cgracsc (nkb, bec1, bec2, nhm, ntyp, nh, qq, nat, ityp, &
real(DP) :: qq (nhm, nhm, ntyp)
! input: the q values defining S
type(pseudo_upf) :: upf (ntyp)
TYPE(pseudo_upf) :: upf (ntyp)
! input: if true the pseudo is vanderb
!
! Here the local variables
!
integer :: ikb, jkb, na, np, ijkb0, ih, jh
INTEGER :: ikb, jkb, na, np, ijkb0, ih, jh
! counter on total beta functions
! counter on total beta functions
! counter on atoms
@ -62,42 +62,42 @@ function cgracsc (nkb, bec1, bec2, nhm, ntyp, nh, qq, nat, ityp, &
! counter on solid beta functions
! counter on solid beta functions
complex(DP) :: scal, zdotc
COMPLEX(DP) :: scal, zdotc
!
scal = zdotc (npw, psi1, 1, psi2, 1)
#ifdef __PARA
call mp_sum( scal, intra_pool_comm )
CALL mp_sum( scal, intra_pool_comm )
#endif
ijkb0 = 0
do np = 1, ntyp
if (upf(np)%tvanp ) then
do na = 1, nat
if (ityp (na) .eq.np) then
do ih = 1, nh (np)
DO np = 1, ntyp
IF (upf(np)%tvanp ) THEN
DO na = 1, nat
IF (ityp (na) ==np) THEN
DO ih = 1, nh (np)
ikb = ijkb0 + ih
do jh = 1, nh (np)
DO jh = 1, nh (np)
jkb = ijkb0 + jh
scal = scal + qq (ih,jh,np)*CONJG(bec1(ikb))*bec2(jkb)
enddo
enddo
scal = scal + qq (ih,jh,np)*conjg(bec1(ikb))*bec2(jkb)
ENDDO
ENDDO
ijkb0 = ijkb0 + nh (np)
endif
enddo
else
do na = 1, nat
if (ityp (na) .eq.np) ijkb0 = ijkb0 + nh (np)
enddo
endif
ENDIF
ENDDO
ELSE
DO na = 1, nat
IF (ityp (na) ==np) ijkb0 = ijkb0 + nh (np)
ENDDO
ENDIF
enddo
ENDDO
cgracsc = scal
return
end function cgracsc
RETURN
END FUNCTION cgracsc
!
!-----------------------------------------------------------------------
function cgracsc_nc (nkb, bec1, bec2, nhm, ntyp, nh, nat, ityp, &
FUNCTION cgracsc_nc (nkb, bec1, bec2, nhm, ntyp, nh, nat, ityp, &
npw, npol, psi1, psi2, upf)
!-----------------------------------------------------------------------
!
@ -113,12 +113,12 @@ function cgracsc_nc (nkb, bec1, bec2, nhm, ntyp, nh, nat, ityp, &
USE pseudo_types, ONLY : pseudo_upf
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
implicit none
IMPLICIT NONE
!
! here the dummy variables
!
integer :: nkb, npw, npol, nhm, ntyp, nat, ityp (nat), nh (ntyp)
INTEGER :: nkb, npw, npol, nhm, ntyp, nat, ityp (nat), nh (ntyp)
! input: the number of beta functions
! input: the number of plane waves
! input: the maximum number of solid be
@ -127,7 +127,7 @@ function cgracsc_nc (nkb, bec1, bec2, nhm, ntyp, nh, nat, ityp, &
! input: the type of each atom
! input: the number of beta for each ty
complex(DP) :: bec1 (nkb,npol), bec2 (nkb,npol), &
COMPLEX(DP) :: bec1 (nkb,npol), bec2 (nkb,npol), &
psi1 (npw,npol), psi2 (npw,npol), cgracsc_nc
! input: the product of beta and psi1
! input: the product of beta and psi2
@ -135,13 +135,13 @@ function cgracsc_nc (nkb, bec1, bec2, nhm, ntyp, nh, nat, ityp, &
! input: the second wavefunction
! output: the value of the scalar produ
type(pseudo_upf) :: upf (ntyp)
TYPE(pseudo_upf) :: upf (ntyp)
! input: if true the pseudo is vanderb
!
! Here the local variables
!
integer :: ikb, jkb, na, np, ijkb0, ih, jh, ipol, jpol, ijh
INTEGER :: ikb, jkb, na, np, ijkb0, ih, jh, ipol, jpol, ijh
! counter on total beta functions
! counter on total beta functions
! counter on atoms
@ -150,48 +150,48 @@ function cgracsc_nc (nkb, bec1, bec2, nhm, ntyp, nh, nat, ityp, &
! counter on solid beta functions
! counter on solid beta functions
complex(DP) :: scal, zdotc
COMPLEX(DP) :: scal, zdotc
!
scal = zdotc (npw*npol, psi1, 1, psi2, 1)
#ifdef __PARA
call mp_sum( scal, intra_pool_comm )
CALL mp_sum( scal, intra_pool_comm )
#endif
ijkb0 = 0
do np = 1, ntyp
if (upf(np)%tvanp ) then
do na = 1, nat
if (ityp (na) .eq.np) then
do ih = 1, nh (np)
DO np = 1, ntyp
IF (upf(np)%tvanp ) THEN
DO na = 1, nat
IF (ityp (na) ==np) THEN
DO ih = 1, nh (np)
ikb = ijkb0 + ih
do jh = 1, nh (np)
DO jh = 1, nh (np)
jkb = ijkb0 + jh
if (lspinorb) then
IF (lspinorb) THEN
ijh=0
do ipol=1,npol
do jpol=1,npol
DO ipol=1,npol
DO jpol=1,npol
ijh=ijh+1
scal=scal+qq_so(ih,jh,ijh,np)* &
CONJG(bec1(ikb,ipol))*bec2(jkb,jpol)
end do
end do
else
do ipol=1,npol
conjg(bec1(ikb,ipol))*bec2(jkb,jpol)
ENDDO
ENDDO
ELSE
DO ipol=1,npol
scal=scal+qq(ih,jh,np)* &
CONJG(bec1(ikb,ipol))*bec2(jkb,ipol)
end do
end if
end do
end do
conjg(bec1(ikb,ipol))*bec2(jkb,ipol)
ENDDO
ENDIF
ENDDO
ENDDO
ijkb0 = ijkb0 + nh (np)
end if
end do
else
do na = 1, nat
if (ityp (na) .eq.np) ijkb0 = ijkb0 + nh (np)
enddo
endif
enddo
ENDIF
ENDDO
ELSE
DO na = 1, nat
IF (ityp (na) ==np) ijkb0 = ijkb0 + nh (np)
ENDDO
ENDIF
ENDDO
cgracsc_nc = scal
return
end function cgracsc_nc
RETURN
END FUNCTION cgracsc_nc

910
PP/chdens.f90
View File

File diff suppressed because it is too large Load Diff

112
PP/compute_ppsi.f90
View File

@ -8,7 +8,7 @@
!
!
!----------------------------------------------------------------------
subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
SUBROUTINE compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
!----------------------------------------------------------------------
!
! On output: ppsi contains P_c^+ p | psi_ik > for the ipol cartesian
@ -34,7 +34,7 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
USE uspp_param, ONLY : nh, nhm
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: ipol, ik, nbnd_occ, current_spin
INTEGER, INTENT(in) :: ipol, ik, nbnd_occ, current_spin
!
COMPLEX(DP) :: ppsi(npwx,npol,nbnd_occ), ppsi_us(npwx,npol,nbnd_occ)
! Local variables
@ -54,36 +54,36 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
COMPLEX(DP), EXTERNAL :: zdotc
!
ALLOCATE (work ( npwx, MAX(nkb,1)))
ALLOCATE (gk ( 3, npwx))
ALLOCATE (work ( npwx, max(nkb,1)))
ALLOCATE (gk ( 3, npwx))
IF (nkb > 0) THEN
IF (noncolin) THEN
ALLOCATE (becp2_nc (nkb, npol, nbnd))
ELSE
ALLOCATE (becp2 (nkb, nbnd))
END IF
ENDIF
ALLOCATE (dvkb (npwx, nkb))
ALLOCATE (dvkb1(npwx, nkb))
dvkb (:,:) = (0.d0, 0.d0)
dvkb1(:,:) = (0.d0, 0.d0)
END IF
ENDIF
DO ig = 1, npw
gk (1, ig) = (xk (1, ik) + g (1, igk (ig) ) ) * tpiba
gk (2, ig) = (xk (2, ik) + g (2, igk (ig) ) ) * tpiba
gk (3, ig) = (xk (3, ik) + g (3, igk (ig) ) ) * tpiba
g2kin (ig) = gk (1, ig) **2 + gk (2, ig) **2 + gk (3, ig) **2
END DO
ENDDO
!
! this is the kinetic contribution to p : (k+G)_ipol * psi
!
DO ip=1,npol
DO ibnd = 1, nbnd_occ
DO ibnd = 1, nbnd_occ
DO ig = 1, npw
ppsi(ig,ip,ibnd)=gk(ipol,ig)*evc(ig+npwx*(ip-1),ibnd)
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
!
! and this is the contribution from nonlocal pseudopotentials
@ -93,16 +93,16 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
vers(ipol)=1.d0
CALL gen_us_dy (ik, vers, dvkb1)
DO ig = 1, npw
IF (g2kin (ig) < 1.0d-10) then
IF (g2kin (ig) < 1.0d-10) THEN
gk (1, ig) = 0.d0
gk (2, ig) = 0.d0
gk (3, ig) = 0.d0
ELSE
gk (1, ig) = gk (1, ig) / SQRT (g2kin (ig) )
gk (2, ig) = gk (2, ig) / SQRT (g2kin (ig) )
gk (3, ig) = gk (3, ig) / SQRT (g2kin (ig) )
END IF
END DO
gk (1, ig) = gk (1, ig) / sqrt (g2kin (ig) )
gk (2, ig) = gk (2, ig) / sqrt (g2kin (ig) )
gk (3, ig) = gk (3, ig) / sqrt (g2kin (ig) )
ENDIF
ENDDO
jkb = 0
DO nt = 1, ntyp
@ -111,12 +111,12 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
DO ikb = 1, nh (nt)
jkb = jkb + 1
DO ig = 1, npw
work (ig,jkb)=dvkb1(ig,jkb)+dvkb(ig,jkb)*gk(ipol,ig)
END DO
END DO
END IF
END DO
END DO
work (ig,jkb)=dvkb1(ig,jkb)+dvkb(ig,jkb)*gk(ipol,ig)
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
DEALLOCATE (gk)
IF (noncolin) THEN
@ -132,7 +132,7 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
ELSE
ALLOCATE (ps2( nkb, nbnd_occ, 2))
ps2=(0.d0,0.d0)
END IF
ENDIF
DO nt = 1, ntyp
DO na = 1, nat
IF (nt == ityp (na)) THEN
@ -140,7 +140,7 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
ikb = ijkb0 + ih
DO jh = 1, nh (nt)
jkb = ijkb0 + jh
DO ibnd = 1, nbnd_occ
DO ibnd = 1, nbnd_occ
IF (noncolin) THEN
IF (lspinorb) THEN
psc(ikb,1,ibnd,1)=psc(ikb,1,ibnd,1)+(0.d0,-1.d0)* &
@ -180,7 +180,7 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
( becp%nc(jkb,2,ibnd)*(deeq_nc(ih,jh,na,4) &
-et(ibnd,ik)*qq(ih,jh,nt))+ &
becp%nc(jkb,1,ibnd)*deeq_nc(ih,jh,na,3) )
END IF
ENDIF
ELSE
ps2(ikb,ibnd,1) = ps2(ikb,ibnd,1)+ becp2(jkb,ibnd)* &
(0.d0,-1.d0)*(deeq(ih,jh,na,current_spin) &
@ -189,14 +189,14 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
(0.d0,-1.d0)*(deeq(ih,jh,na,current_spin)&
-et(ibnd,ik)*qq(ih,jh,nt))
ENDIF
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ijkb0=ijkb0+nh(nt)
END IF
END DO
END DO
IF (ikb /= nkb .OR. jkb /= nkb) CALL errore ('compute_ppsi', &
ENDIF
ENDDO
ENDDO
IF (ikb /= nkb .or. jkb /= nkb) CALL errore ('compute_ppsi', &
'unexpected error',1)
IF (nkb>0) THEN
@ -214,13 +214,13 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
CALL zgemm( 'N', 'N', npw, nbnd_occ, nkb, &
(0.d0,0.5d0), work(1,1), npwx, ps2(1,1,2), nkb, (1.d0,0.0d0), &
ppsi, npwx )
END IF
END IF
ENDIF
ENDIF
IF (noncolin) THEN
DEALLOCATE (psc)
ELSE
DEALLOCATE (ps2)
END IF
ENDIF
!
! ppsi contains p - i/2 [x, V_{nl}-eS] psi_v for the ipol polarization
!
@ -234,13 +234,13 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
ALLOCATE (dpqq( nhm, nhm, 3, ntyp))
CALL compute_qdipol(dpqq,ipol)
IF (noncolin) THEN
ALLOCATE (ps_nc(nbnd_occ,npol))
ALLOCATE (ps_nc(nbnd_occ,npol))
IF (lspinorb) THEN
ALLOCATE (dpqq_so( nhm, nhm, nspin, 3, ntyp))
CALL compute_qdipol_so(dpqq, dpqq_so,ipol)
END IF
ENDIF
ELSE
ALLOCATE (ps(nbnd_occ))
ALLOCATE (ps(nbnd_occ))
ENDIF
ijkb0 = 0
DO nt = 1, ntyp
@ -252,7 +252,7 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
ps_nc = (0.d0,0.d0)
ELSE
ps = (0.d0,0.d0)
END IF
ENDIF
DO jh = 1, nh (nt)
jkb = ijkb0 + jh
DO ibnd=1, nbnd_occ
@ -273,36 +273,36 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
becp2_nc(jkb,ip,ibnd)*(0.d0,1.d0)* &
qq(ih,jh,nt)+becp%nc(jkb,ip,ibnd) &
*dpqq(ih,jh,ipol,nt)
END IF
END DO
ENDIF
ENDDO
ELSE
ps(ibnd) = ps(ibnd) + becp2(jkb,ibnd) * &
(0.d0,1.d0) * qq(ih,jh,nt) + &
becp%k(jkb,ibnd) * dpqq(ih,jh,ipol,nt)
END IF
END DO
END DO
DO ibnd = 1, nbnd_occ
ENDIF
ENDDO
ENDDO
DO ibnd = 1, nbnd_occ
IF (noncolin) THEN
DO ip=1,npol
CALL zaxpy(npw,ps_nc(ibnd,ip),vkb(1,ikb),1,&
ppsi_us(1,ip,ibnd),1)
END DO
ENDDO
ELSE
CALL zaxpy(npw,ps(ibnd),vkb(1,ikb),1,ppsi_us(1,1,ibnd),1)
ENDIF
END DO
END DO
ENDDO
ENDDO
ijkb0=ijkb0+nh(nt)
END IF
END DO
END DO
IF (jkb.NE.nkb) CALL errore ('compute_ppsi', 'unexpected error', 1)
ENDIF
ENDDO
ENDDO
IF (jkb/=nkb) CALL errore ('compute_ppsi', 'unexpected error', 1)
IF (noncolin) THEN
DEALLOCATE(ps_nc)
ELSE
DEALLOCATE(ps)
END IF
ENDIF
ENDIF
@ -312,8 +312,8 @@ subroutine compute_ppsi (ppsi, ppsi_us, ik, ipol, nbnd_occ, current_spin)
DEALLOCATE(becp2_nc)
ELSE
DEALLOCATE(becp2)
END IF
END IF
ENDIF
ENDIF
DEALLOCATE (work)
RETURN

180
PP/compute_sigma_avg.f90
View File

@ -16,7 +16,7 @@ USE cell_base, ONLY : alat, at, tpiba, omega
USE spin_orb, ONLY : fcoef
USE uspp, ONLY : nkb,qq,vkb,nhtol,nhtoj,nhtolm,indv
USE uspp_param, ONLY : upf, nh, nhm
USE wvfct, ONLY : nbnd, npwx, npw, igk
USE wvfct, ONLY : nbnd, npwx, npw, igk
USE wavefunctions_module, ONLY : evc, psic_nc
USE klist, ONLY : nks, xk
USE gvect, ONLY : g,gg,nr1,nr2,nr3,nrx1,nrx2,nrx3,nrxx
@ -34,9 +34,9 @@ IMPLICIT NONE
LOGICAL :: lsigma(4)
! if true the expectation value in this direction is calculated
COMPLEX(DP) :: becp_nc(nkb,npol,nbnd)
!
REAL(KIND=DP) :: sigma_avg(4,nbnd)
INTEGER :: ik
!
REAL(kind=DP) :: sigma_avg(4,nbnd)
INTEGER :: ik
INTEGER :: ibnd, ig, ir, ijkb0, na, np, ih, ikb, jh
INTEGER :: ipol, kh, kkb, is1, is2, npwi, npwf
@ -48,7 +48,7 @@ COMPLEX(DP), ALLOCATABLE :: dfx(:), dfy(:)
COMPLEX(DP) :: c_aux, zdotc
IF (.NOT.(lsigma(1).OR.lsigma(2).OR.lsigma(3).OR.lsigma(4))) RETURN
IF (.not.(lsigma(1).or.lsigma(2).or.lsigma(3).or.lsigma(4))) RETURN
ALLOCATE(be1(nhm,2))
ALLOCATE(dfx(nrxxs), dfy(nrxxs))
@ -68,82 +68,82 @@ DO np=1, ntyp
DO ih = 1, nh (np)
li = nhtol(ih,np)
mi = nhtolm(ih,np) - li**2
IF (mi.EQ.2) THEN
IF (mi==2) THEN
mi1 = 3
c_aux = -(0.d0,1.d0)
ELSE IF (mi.EQ.3) THEN
ELSEIF (mi==3) THEN
mi1 = 2
c_aux = (0.d0,1.d0)
ELSE IF (mi.EQ.4) THEN
ELSEIF (mi==4) THEN
mi1 = 5
c_aux = -(0.d0,2.d0)
ELSE IF (mi.EQ.5) THEN
ELSEIF (mi==5) THEN
mi1 = 4
c_aux = (0.d0,2.d0)
END IF
ENDIF
DO jh = ih+1, nh (np)
lj = nhtol(jh,np)
mj = nhtolm(jh,np) - lj**2
IF (lj.EQ.li.AND.mj.EQ.mi1) THEN
IF (mj.GT.mi) THEN
IF (lj==li.and.mj==mi1) THEN
IF (mj>mi) THEN
r_aux = qq(ih,jh-1,np)
ELSE
r_aux = qq(ih,jh+1,np)
END IF
ENDIF
qq_lz(ih,jh,np) = c_aux * r_aux
END IF
END DO
END DO
ENDIF
ENDDO
ENDDO
DO ih = 1, nh (np)
DO jh = 1, ih-1
qq_lz(ih,jh,np) = CONJG(qq_lz(jh,ih,np))
END DO
END DO
END DO
qq_lz(ih,jh,np) = conjg(qq_lz(jh,ih,np))
ENDDO
ENDDO
ENDDO
DO ibnd = 1, nbnd
rho%of_r = 0.d0
magtot1 = 0.d0
magtot2 = 0.d0
magtot2 = 0.d0
!-- Pseudo part
psic_nc = (0.D0,0.D0)
DO ig = 1, npw
psic_nc(nls(igk(ig)), 1)=evc(ig ,ibnd)
psic_nc(nls(igk(ig)), 2)=evc(ig+npwx,ibnd)
END DO
ENDDO
DO ipol=1,npol
call cft3s (psic_nc(1,ipol), nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
CALL cft3s (psic_nc(1,ipol), nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
ENDDO
!
! Calculate the three components of the magnetization
! Calculate the three components of the magnetization
! (stored in rho%of_r(ir,2-4) )
!
IF (lsigma(1)) THEN
DO ir = 1,nrxxs
rho%of_r(ir,2) = rho%of_r(ir,2) + 2.D0* &
(REAL(psic_nc(ir,1))*REAL(psic_nc(ir,2)) + &
AIMAG(psic_nc(ir,1))*AIMAG(psic_nc(ir,2)))
END DO
aimag(psic_nc(ir,1))*aimag(psic_nc(ir,2)))
ENDDO
IF (doublegrid) CALL interpolate( rho%of_r(1,2), rho%of_r(1,2), 1 )
END IF
ENDIF
IF (lsigma(2)) THEN
DO ir = 1,nrxxs
rho%of_r(ir,3) = rho%of_r(ir,3) + 2.D0* &
(REAL(psic_nc(ir,1))*AIMAG(psic_nc(ir,2)) - &
REAL(psic_nc(ir,2))*AIMAG(psic_nc(ir,1)))
END DO
(REAL(psic_nc(ir,1))*aimag(psic_nc(ir,2)) - &
REAL(psic_nc(ir,2))*aimag(psic_nc(ir,1)))
ENDDO
IF (doublegrid) CALL interpolate( rho%of_r(1,3), rho%of_r(1,3), 1 )
END IF
ENDIF
IF (lsigma(3)) THEN
DO ir = 1,nrxxs
rho%of_r(ir,4) = rho%of_r(ir,4) + &
(REAL(psic_nc(ir,1))**2+AIMAG(psic_nc(ir,1))**2 &
-REAL(psic_nc(ir,2))**2-AIMAG(psic_nc(ir,2))**2)
END DO
(REAL(psic_nc(ir,1))**2+aimag(psic_nc(ir,1))**2 &
-REAL(psic_nc(ir,2))**2-aimag(psic_nc(ir,2))**2)
ENDDO
IF (doublegrid) CALL interpolate( rho%of_r(1,4), rho%of_r(1,4), 1 )
END IF
ENDIF
IF (lsigma(4)) THEN
!-- Calculate pseudo part of L_z
@ -163,35 +163,35 @@ DO ibnd = 1, nbnd
DO j = 1, nr2s
yy = (j-1)*dy - y0
r_aux = DSQRT (xx**2 + yy**2)
IF (r_aux.LE.r_cut) THEN
IF (r_aux<=r_cut) THEN
DO k = 1, dffts%npp(me_pool+1)
ijk = i + (j-1) * nrx1s + (k-1) * nrx1s * nrx2s
dfx(ijk) = xx * dfy(ijk) - yy * dfx(ijk)
END DO
ENDDO
ELSE
DO k = 1, dffts%npp(me_pool+1)
ijk = i + (j-1) * nrx1s + (k-1) * nrx1s * nrx2s
dfx (ijk) = 0.d0
END DO
END IF
END DO
END DO
ENDDO
ENDIF
ENDDO
ENDDO
c_aux = zdotc(nrxxs, psic_nc(1,ipol), 1, dfx, 1)
magtot1(4) = magtot1(4) + AIMAG(c_aux)
END DO
magtot1(4) = magtot1(4) + aimag(c_aux)
ENDDO
CALL mp_sum( magtot1(4), intra_pool_comm )
magtot1(4) = magtot1(4)/(nr1s*nr2s*nr3s)
END IF
ENDIF
DO ipol=1,3
IF (lsigma(ipol)) THEN
DO ir = 1,nrxx
magtot1(ipol) = magtot1(ipol) + rho%of_r(ir,ipol+1)
END DO
ENDDO
CALL mp_sum( magtot1(ipol), intra_pool_comm )
magtot1(ipol) = magtot1(ipol) / ( nr1 * nr2 * nr3 )
END IF
END DO
ENDIF
ENDDO
!-- Augmentation part
@ -210,8 +210,8 @@ DO ibnd = 1, nbnd
ikb = ijkb0 + ih
IF (upf(np)%has_so) THEN
DO kh = 1, nh(np)
IF ((nhtol(kh,np)==nhtol(ih,np)).AND. &
(nhtoj(kh,np)==nhtoj(ih,np)).AND. &
IF ((nhtol(kh,np)==nhtol(ih,np)).and. &
(nhtoj(kh,np)==nhtoj(ih,np)).and. &
(indv(kh,np)==indv(ih,np))) THEN
kkb=ijkb0 + kh
DO is1=1,2
@ -219,65 +219,65 @@ DO ibnd = 1, nbnd
be1(ih,is1)=be1(ih,is1)+ &
fcoef(ih,kh,is1,is2,np)* &
becp_nc(kkb,is2,ibnd)
END DO
END DO
END IF
END DO
ENDDO
ENDDO
ENDIF
ENDDO
ELSE
DO is1=1,2
DO is1=1,2
be1(ih,is1) = becp_nc(ikb,is1,ibnd)
END DO
END IF
END DO
ENDDO
ENDIF
ENDDO
IF (lsigma(1)) THEN
DO ih = 1, nh(np)
magtot2(1)=magtot2(1)+ 2.d0*qq(ih,ih,np) &
* REAL( be1(ih,2)*CONJG(be1(ih,1)) )
DO jh = ih + 1, nh(np)
* REAL( be1(ih,2)*conjg(be1(ih,1)) )
DO jh = ih + 1, nh(np)
magtot2(1)=magtot2(1)+2.d0*qq(ih,jh,np) &
* REAL( be1(jh,2)*CONJG(be1(ih,1))+ &
be1(jh,1)*CONJG(be1(ih,2)) )
* REAL( be1(jh,2)*conjg(be1(ih,1))+ &
be1(jh,1)*conjg(be1(ih,2)) )
ENDDO
ENDDO
ENDIF
IF (lsigma(2)) THEN
DO ih = 1, nh(np)
magtot2(2)=magtot2(2)+ 2.d0*qq(ih,ih,np)*AIMAG &
( be1(ih,2)*CONJG(be1(ih,1)) )
DO jh = ih + 1, nh(np)
magtot2(2)=magtot2(2) + 2.d0*qq(ih,jh,np)*AIMAG &
( be1(jh,2) * CONJG(be1(ih,1)) &
- be1(jh,1) * CONJG(be1(ih,2)) )
END DO
END DO
END IF
magtot2(2)=magtot2(2)+ 2.d0*qq(ih,ih,np)*aimag &
( be1(ih,2)*conjg(be1(ih,1)) )
DO jh = ih + 1, nh(np)
magtot2(2)=magtot2(2) + 2.d0*qq(ih,jh,np)*aimag &
( be1(jh,2) * conjg(be1(ih,1)) &
- be1(jh,1) * conjg(be1(ih,2)) )
ENDDO
ENDDO
ENDIF
IF (lsigma(3)) THEN
DO ih = 1, nh(np)
magtot2(3) = magtot2(3) + qq(ih,ih,np)* &
( ABS(be1(ih,1))**2 - ABS(be1(ih,2))**2 )
DO jh = ih + 1, nh(np)
( abs(be1(ih,1))**2 - abs(be1(ih,2))**2 )
DO jh = ih + 1, nh(np)
magtot2(3) = magtot2(3) + 2.d0*qq(ih,jh,np) &
* REAL( be1(jh,1)*CONJG(be1(ih,1)) &
-be1(jh,2)*CONJG(be1(ih,2)) )
END DO
END DO
END IF
* REAL( be1(jh,1)*conjg(be1(ih,1)) &
-be1(jh,2)*conjg(be1(ih,2)) )
ENDDO
ENDDO
ENDIF
IF (lsigma(4)) THEN
DO ih = 1, nh(np)
DO jh = ih + 1, nh(np)
DO jh = ih + 1, nh(np)
magtot2(4)= magtot2(4)+2.d0*REAL(qq_lz(ih,jh,np)* &
( CONJG(be1(ih,1))*be1(jh,1) + &
CONJG(be1(ih,2))*be1(jh,2) ) )
END DO
END DO
END IF
( conjg(be1(ih,1))*be1(jh,1) + &
conjg(be1(ih,2))*be1(jh,2) ) )
ENDDO
ENDDO
ENDIF
!
ijkb0 = ijkb0 + nh(np)
!
END IF
ENDIF
!
END DO
ENDDO
!
ELSE
!
@ -285,20 +285,20 @@ DO ibnd = 1, nbnd
!
IF ( ityp(na) == np ) ijkb0 = ijkb0 + nh(np)
!
END DO
ENDDO
!
END IF
ENDIF
!
END DO
ENDDO
DO ipol=1,3
IF (lsigma(ipol)) &
sigma_avg(ipol,ibnd) = 0.5d0 * ( magtot1(ipol) + magtot2(ipol) )
END DO
ENDDO
IF (lsigma(4)) &
sigma_avg(4,ibnd) = magtot1(4) + magtot2(4) + sigma_avg(3,ibnd)
END DO
ENDDO
DEALLOCATE(be1)
DEALLOCATE(dfx,dfy)

60
PP/cube.f90
View File

@ -19,19 +19,19 @@
! plain dumping of the data. no re-gridding or transformation to an
! orthorhombic box (needed for most .cube aware programs :-/).
! -------------------------------------------------------------------
subroutine write_cubefile ( alat, at, bg, nat, tau, atm, ityp, rho, &
SUBROUTINE write_cubefile ( alat, at, bg, nat, tau, atm, ityp, rho, &
nr1, nr2, nr3, nrx1, nrx2, nrx3, ounit )
USE kinds, only : DP
USE kinds, ONLY : DP
implicit none
integer :: nat, ityp(nat), ounit,nr1, nr2, nr3, nrx1, nrx2, nrx3
character(len=3) :: atm(*)
IMPLICIT NONE
INTEGER :: nat, ityp(nat), ounit,nr1, nr2, nr3, nrx1, nrx2, nrx3
CHARACTER(len=3) :: atm(*)
real(DP) :: alat, tau(3,nat), at(3,3), bg(3,3), rho(nrx1,nrx2,nrx3)
! --
integer :: i, nt, i1, i2, i3, at_num
integer, external:: atomic_number
INTEGER :: i, nt, i1, i2, i3, at_num
INTEGER, EXTERNAL:: atomic_number
real(DP) :: at_chrg, tpos(3), inpos(3)
!C WRITE A FORMATTED 'DENSITY-STYLE' CUBEFILE VERY SIMILAR
@ -50,34 +50,34 @@ subroutine write_cubefile ( alat, at, bg, nat, tau, atm, ityp, rho, &
!C
!C ALL COORDINATES ARE GIVEN IN ATOMIC UNITS.
write(ounit,*) 'Cubfile created from PWScf calculation'
write(ounit,*) ' Total SCF Density'
WRITE(ounit,*) 'Cubfile created from PWScf calculation'
WRITE(ounit,*) ' Total SCF Density'
! origin is forced to (0.0,0.0,0.0)
write(ounit,'(I5,3F12.6)') nat, 0.0d0, 0.0d0, 0.0d0
write(ounit,'(I5,3F12.6)') nr1, (alat*at(i,1)/DBLE(nr1),i=1,3)
write(ounit,'(I5,3F12.6)') nr2, (alat*at(i,2)/DBLE(nr2),i=1,3)
write(ounit,'(I5,3F12.6)') nr3, (alat*at(i,3)/DBLE(nr3),i=1,3)
WRITE(ounit,'(I5,3F12.6)') nat, 0.0d0, 0.0d0, 0.0d0
WRITE(ounit,'(I5,3F12.6)') nr1, (alat*at(i,1)/dble(nr1),i=1,3)
WRITE(ounit,'(I5,3F12.6)') nr2, (alat*at(i,2)/dble(nr2),i=1,3)
WRITE(ounit,'(I5,3F12.6)') nr3, (alat*at(i,3)/dble(nr3),i=1,3)
do i=1,nat
DO i=1,nat
nt = ityp(i)
! find atomic number for this atom.
at_num = atomic_number(TRIM(atm(nt)))
at_chrg= DBLE(at_num)
! find atomic number for this atom.
at_num = atomic_number(trim(atm(nt)))
at_chrg= dble(at_num)
! at_chrg could be alternatively set to valence charge
! positions are in cartesian coordinates and a.u.
!
! wrap coordinates back into cell.
tpos = MATMUL( TRANSPOSE(bg), tau(:,i) )
tpos = tpos - NINT(tpos - 0.5d0)
inpos = alat * MATMUL( at, tpos )
write(ounit,'(I5,5F12.6)') at_num, at_chrg, inpos
enddo
do i1=1,nr1
do i2=1,nr2
write(ounit,'(6E13.5)') (rho(i1,i2,i3),i3=1,nr3)
enddo
enddo
return
end subroutine write_cubefile
tpos = matmul( transpose(bg), tau(:,i) )
tpos = tpos - nint(tpos - 0.5d0)
inpos = alat * matmul( at, tpos )
WRITE(ounit,'(I5,5F12.6)') at_num, at_chrg, inpos
ENDDO
DO i1=1,nr1
DO i2=1,nr2
WRITE(ounit,'(6E13.5)') (rho(i1,i2,i3),i3=1,nr3)
ENDDO
ENDDO
RETURN
END SUBROUTINE write_cubefile

14
PP/cubicspinsym.f90
View File

@ -12,7 +12,7 @@ SUBROUTINE cubicspinsym(d_spin)
! Provides symmetry operations in the spin space for all cubic and
! lower-symmetry (excepted Hexagonal and Trigonal) bravais lattices
!
USE kinds
USE kinds
USE symm_base, ONLY : nsym, sname
!
IMPLICIT NONE
@ -21,11 +21,11 @@ SUBROUTINE cubicspinsym(d_spin)
!
COMPLEX(DP) :: d_spin(2,2,48)
! output: the symmetries of the system in the j=1/2 subspace
!
!
! here the local parameters
!
REAL(DP), parameter :: cost1=0.707106781186547d0, cost2=0.5d0, &
mcost1=-0.707106781186547d0, mcost2=-0.5d0
REAL(DP), PARAMETER :: cost1=0.707106781186547d0, cost2=0.5d0, &
mcost1=-0.707106781186547d0, mcost2=-0.5d0
!
! and the local variables
!
@ -33,7 +33,7 @@ SUBROUTINE cubicspinsym(d_spin)
!
! symmetry matrices in the j=1/2 subspace
!
INTEGER :: i,j
INTEGER :: i,j
!
! counter over the rotations
! counter over the rotations
@ -41,7 +41,7 @@ SUBROUTINE cubicspinsym(d_spin)
CHARACTER :: isname (48) * 45
!
! full name of the rotational part of each symmetry operation
!
!
data isname/&
& 'identity ',&
& '180 deg rotation - cart. axis [0,0,1] ',&
@ -151,6 +151,6 @@ SUBROUTINE cubicspinsym(d_spin)
ENDIF
ENDDO
ENDDO
RETURN
RETURN
!
END SUBROUTINE cubicspinsym

162
PP/d_matrix_nc.f90
View File

@ -7,12 +7,12 @@
!
!
!---------------------------------------------------------------
SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
!---------------------------------------------------------------
!
! Provides symmetry operations in the (l, s) subspaces for l=0,1,2,3
! Provides symmetry operations in the (l, s) subspaces for l=0,1,2,3
!
USE kinds, only: DP
USE kinds, ONLY: DP
USE cell_base, ONLY : ibrav, symm_type
USE symm_base, ONLY: nsym, sr
USE random_numbers, ONLY : randy
@ -25,7 +25,7 @@ SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
dy312 (14, 14, 48)
!
! output: symmetry matrices in the l=0, l=1, l=2 and l=3 subspace resp.
!
!
! here the local parameters
!
INTEGER, PARAMETER :: maxl = 3, maxm = 2*maxl+1, &
@ -38,7 +38,7 @@ SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
REAL(DP), PARAMETER :: eps = 1.0d-9
!
! and the local variables
!
!
INTEGER :: m, n, m1, n1, ipol, isym
INTEGER :: l, n2, ind, ind1, ind2
REAL(DP) :: ylm(maxm, maxlm), ylms(maxm, maxlm), &
@ -52,36 +52,36 @@ SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
!
! Here we find the true symmetries of the crystal
!
IF ( ibrav == 4 .OR. ibrav == 5 ) THEN
IF ( ibrav == 4 .or. ibrav == 5 ) THEN
!
! ... here the hexagonal or trigonal bravais lattice
!
CALL hexspinsym( s_spin )
!
ELSE IF ( ibrav >=1 .AND. ibrav <= 14 ) THEN
ELSEIF ( ibrav >=1 .and. ibrav <= 14 ) THEN
!
! ... here for the cubic bravais lattice
!
CALL cubicspinsym( s_spin )
!
ELSE IF ( ibrav == 0 ) THEN
ELSEIF ( ibrav == 0 ) THEN
!
IF ( symm_type == 'cubic' ) THEN
!
CALL cubicspinsym( s_spin )
!
ELSE IF ( symm_type == 'hexagonal' ) THEN
ELSEIF ( symm_type == 'hexagonal' ) THEN
!
CALL hexspinsym( s_spin )
!
END IF
ENDIF
!
ELSE
!
CALL errore( 'd_matrix_nc', 'wrong ibrav', 1 )
!
END IF
!
ENDIF
!
! randomly distributed points on a sphere
!
DO m = 1, maxm
@ -89,37 +89,37 @@ SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
rl (2, m) = randy () - 0.5d0
rl (3, m) = randy () - 0.5d0
rrl (m) = rl (1,m)**2 + rl (2,m)**2 + rl (3,m)**2
END DO
ENDDO
CALL ylmr2 ( maxlm, 2*maxl+1, rl, rrl, ylm )
!
! invert Yl for each block of definite l (note the transpose operation)
!
! l = 1 block
!
do m = 1, 3
do n = 1, 3
!
DO m = 1, 3
DO n = 1, 3
yl1 (m, n) = ylm (n, 1+m)
end do
end do
call invmat (3, yl1, yl1_inv, capel)
ENDDO
ENDDO
CALL invmat (3, yl1, yl1_inv, capel)
!
! l = 2 block
!
do m = 1, 5
do n = 1, 5
DO m = 1, 5
DO n = 1, 5
yl2 (m, n) = ylm (n, 4+m)
end do
end do
call invmat (5, yl2, yl2_inv, capel)
ENDDO
ENDDO
CALL invmat (5, yl2, yl2_inv, capel)
!
! l = 3 block
!
do m = 1, 7
do n = 1, 7
DO m = 1, 7
DO n = 1, 7
yl3 (m, n) = ylm (n, 9+m)
end do
end do
call invmat (7, yl3, yl3_inv, capel)
ENDDO
ENDDO
CALL invmat (7, yl3, yl3_inv, capel)
!
! now for each symmetry operation of the point-group ...
!
@ -138,130 +138,130 @@ SUBROUTINE d_matrix_nc (dy012, dy112, dy212, dy312)
!
DO m1 = 1, 2
DO n1 = 1, 2
dy012 (m1, n1, isym)= CONJG( s_spin (n1, m1, isym) )
END DO
END DO
dy012 (m1, n1, isym)= conjg( s_spin (n1, m1, isym) )
ENDDO
ENDDO
!
! l = 1 block
! l = 1 block
!
DO m = 1, 3
DO n = 1, 3
yl1 (m, n) = ylms (n, 1+m)
END DO
END DO
ENDDO
ENDDO
dy1 (:, :, isym) = matmul (yl1(:,:), yl1_inv(:,:))
DO m = 1, 3
DO n = 1, 3
DO m1 = 1, 2
DO n1 = 1, 2
dy112 (m+3*(m1-1), n+3*(n1-1), isym) = &
CMPLX(dy1 (m, n, isym), 0.d0,kind=DP) * s_spin (m1, n1, isym)
END DO
END DO
END DO
END DO
dy112 (m+3*(m1-1), n+3*(n1-1), isym) = &
cmplx(dy1 (m, n, isym), 0.d0,kind=DP) * s_spin (m1, n1, isym)
ENDDO
ENDDO
ENDDO
ENDDO
!
! l = 2 block
! l = 2 block
!
DO m = 1, 5
DO n = 1, 5
yl2 (m, n) = ylms (n, 4+m)
END DO
END DO
ENDDO
ENDDO
dy2 (:, :, isym) = matmul (yl2(:,:), yl2_inv(:,:))
DO m = 1, 5
DO n = 1, 5
DO m1 = 1, 2
DO n1 = 1, 2
dy212 (m+5*(m1-1), n+5*(n1-1), isym) = &
CMPLX(dy2 (m, n, isym), 0.d0,kind=DP) * s_spin (m1, n1, isym)
END DO
END DO
END DO
END DO
dy212 (m+5*(m1-1), n+5*(n1-1), isym) = &
cmplx(dy2 (m, n, isym), 0.d0,kind=DP) * s_spin (m1, n1, isym)
ENDDO
ENDDO
ENDDO
ENDDO
!
! l = 3 block
!
DO m = 1, 7
DO n = 1, 7
yl3 (m, n) = ylms (n, 9+m)
END DO
END DO
ENDDO
ENDDO
dy3 (:, :, isym) = matmul (yl3(:,:), yl3_inv(:,:))
DO m = 1, 7
DO n = 1, 7
DO m1 = 1, 2
DO n1 = 1, 2
dy312 (m+7*(m1-1), n+7*(n1-1), isym) = &
CMPLX(dy3 (m, n, isym), 0.d0,kind=DP) * s_spin (m1, n1, isym)
END DO
END DO
END DO
END DO
cmplx(dy3 (m, n, isym), 0.d0,kind=DP) * s_spin (m1, n1, isym)
ENDDO
ENDDO
ENDDO
ENDDO
!
END DO
ENDDO
!
! check that D_S matrices are unitary as they should
! check that D_S matrices are unitary as they should
!
delta (:,:) = (0.d0,0.d0)
DO m= 1, 14
delta(m,m) = (1.d0,0.d0)
END DO
ENDDO
DO isym =1,nsym
!
! l = 0 block
!
capel = 0.d0
dy012_con(:,:) = CONJG( dy012(:,:,isym) )
dy012_con(:,:) = conjg( dy012(:,:,isym) )
DO m = 1, 2
DO n = 1, 2
capel = capel + &
ABS(ZDOTU(2,dy012_con(1,m),1,dy012(1,n,isym),1)-delta(m,n))**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_nc', &
abs(ZDOTU(2,dy012_con(1,m),1,dy012(1,n,isym),1)-delta(m,n))**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_nc', &
'D_S (l=0) for this symmetry operation is not unitary',isym)
!
! l = 1 block
!
capel = 0.d0
dy112_con(:,:) = CONJG( dy112(:,:,isym) )
dy112_con(:,:) = conjg( dy112(:,:,isym) )
DO m = 1, 6
DO n = 1, 6
capel = capel + &
ABS(ZDOTU(6, dy112_con(1,m), 1, dy112(1,n,isym), 1)-delta(m,n))**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_nc', &
abs(ZDOTU(6, dy112_con(1,m), 1, dy112(1,n,isym), 1)-delta(m,n))**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_nc', &
'D_S (l=1) for this symmetry operation is not unitary',isym)
!
! l = 2 block
!
capel = 0.d0
dy212_con(:,:)=CONJG(dy212(:,:,isym))
dy212_con(:,:)=conjg(dy212(:,:,isym))
DO m = 1, 10
DO n = 1, 10
capel = capel + &
ABS(ZDOTU(10, dy212_con(1,m), 1, dy212(1,n,isym), 1)-delta(m,n))**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_nc', &
abs(ZDOTU(10, dy212_con(1,m), 1, dy212(1,n,isym), 1)-delta(m,n))**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_nc', &
'D_S (l=2) for this symmetry operation is not unitary',isym)
!
! l = 3 block
!
capel = 0.d0
dy312_con(:,:)=CONJG(dy312(:,:,isym))
dy312_con(:,:)=conjg(dy312(:,:,isym))
DO m = 1, 14
DO n = 1, 14
capel = capel + &
ABS(ZDOTU(14, dy312_con(1,m), 1, dy312(1,n,isym), 1)-delta(m,n))**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_nc', &
abs(ZDOTU(14, dy312_con(1,m), 1, dy312(1,n,isym), 1)-delta(m,n))**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_nc', &
'D_S (l=3) for this symmetry operation is not unitary',isym)
!
END DO
ENDDO
!
RETURN
!

198
PP/d_matrix_so.f90
View File

@ -7,13 +7,13 @@
!
!
!---------------------------------------------------------------
SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
!---------------------------------------------------------------
!
! Provides symmetry operations in the j=1/2, j=3/2, j=5/2 and j=7/2
! subspaces
! Provides symmetry operations in the j=1/2, j=3/2, j=5/2 and j=7/2
! subspaces
!
USE kinds, only: DP
USE kinds, ONLY: DP
USE cell_base, ONLY : ibrav, symm_type
USE symm_base, ONLY: nsym, sr
USE spin_orb, ONLY : rot_ylm
@ -26,9 +26,9 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
COMPLEX(DP) :: dyj12 (2, 2, 48), dyj32 (4, 4, 48), dyj52 (6, 6, 48), &
dyj72 (8, 8, 48)
!
! output: symmetry matrices in the j=1/2, j=3/2, j=5/2 and j=7/2 subspace
! output: symmetry matrices in the j=1/2, j=3/2, j=5/2 and j=7/2 subspace
! respectively
!
!
! here the local parameters
!
INTEGER, PARAMETER :: maxl = 3, maxm = 2*maxl+1, &
@ -43,14 +43,14 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
REAL(DP), PARAMETER :: eps = 1.0d-9
!
! and the local variables
!
!
INTEGER :: m, n, m1, n1, ipol, isym
INTEGER :: l, n2, ind, ind1, ind2
REAL(DP) :: j, ylm(maxm, maxlm), ylms(maxm, maxlm), &
rl(3,maxm), rrl (maxm), srl(3,maxm), capel
REAL(DP) :: Ulall(maxl,maxmj+(maxmj-1),maxmj+(maxmj-1)), spinor, &
Ul1(6,6), Ul1_inv(6,6), Ul3(14,14), Ul3_inv(14,14)
COMPLEX(DP) :: dy1 (3, 3, 48), dy2 (5, 5, 48), &
COMPLEX(DP) :: dy1 (3, 3, 48), dy2 (5, 5, 48), &
dy3 (7, 7, 48), dy112 (6, 6, 48), &
dy212 (10, 10, 48), dy312 (14, 14, 48), &
d12_con(2,2), d32_con(4,4), d52_con(6,6), d72_con(8,8), &
@ -61,62 +61,62 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
Ul1C(6,6), Ul1C_inv(6,6), Ul3C(14,14), Ul3C_inv(14,14)
COMPLEX(DP), EXTERNAL :: ZDOTU
!
! Here we find the true symmetries of the crystal
! Here we find the true symmetries of the crystal
!
IF ( ibrav == 4 .OR. ibrav == 5 ) THEN
IF ( ibrav == 4 .or. ibrav == 5 ) THEN
!
! ... here the hexagonal or trigonal bravais lattice
!
CALL hexspinsym( s_spin )
!
ELSE IF ( ibrav >=1 .AND. ibrav <= 14 ) THEN
ELSEIF ( ibrav >=1 .and. ibrav <= 14 ) THEN
!
! ... here for the cubic bravais lattice
!
CALL cubicspinsym( s_spin )
!
ELSE IF ( ibrav == 0 ) THEN
ELSEIF ( ibrav == 0 ) THEN
!
IF ( symm_type == 'cubic' ) THEN
!
CALL cubicspinsym( s_spin )
!
ELSE IF ( symm_type == 'hexagonal' ) THEN
ELSEIF ( symm_type == 'hexagonal' ) THEN
!
CALL hexspinsym( s_spin )
!
END IF
ENDIF
!
ELSE
!
CALL errore( 'd_matrix_so', 'wrong ibrav', 1 )
!
END IF
ENDIF
!
! Transformation matrices from the | l m s s_z > basis to the
! Transformation matrices from the | l m s s_z > basis to the
! | j mj l s > basis in the l-subspace
!
Ulall (:,:,:) = 0.d0
DO l = 1, 3
j = DBLE(l) - 0.5d0
j = dble(l) - 0.5d0
DO m1= 1, 2*l
m= m1 - l
Ulall (l,m1,2*(m1-1)+1) = spinor (l,j,m,1)
Ulall (l,m1,2*(m1-1)+4) = spinor (l,j,m,2)
END DO
j = DBLE(l) + 0.5d0
ENDDO
j = dble(l) + 0.5d0
DO m1= 1, 2*l + 2
m = m1 - l - 2
IF (m1 == 1) THEN
Ulall (l,m1+2*l,2*(m1-1)+2) = spinor (l,j,m,2)
ELSE IF (m1==2*l+2) THEN
ELSEIF (m1==2*l+2) THEN
Ulall (l,m1+2*l,2*(m1-1)-1) = spinor (l,j,m,1)
ELSE
ELSE
Ulall (l,m1+2*l,2*(m1-1)-1) = spinor (l,j,m,1)
Ulall (l,m1+2*l,2*(m1-1)+2) = spinor (l,j,m,2)
END IF
END DO
END DO
ENDIF
ENDDO
ENDDO
!
! invert Ulall for l = 1 and l = 3 blocks
@ -127,23 +127,23 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO m = 1, 6
DO n = 1, 6
Ul1 (m, n) = Ulall (1, m, n)
END DO
END DO
ENDDO
ENDDO
CALL invmat (6, Ul1, Ul1_inv, capel)
Ul1C (:,:) = CMPLX(Ul1 (:,:), 0.d0,kind=DP)
Ul1C_inv (:,:) = CMPLX(Ul1_inv (:,:), 0.d0,kind=DP)
Ul1C (:,:) = cmplx(Ul1 (:,:), 0.d0,kind=DP)
Ul1C_inv (:,:) = cmplx(Ul1_inv (:,:), 0.d0,kind=DP)
!
! l = 3 block
!
DO m = 1, 14
DO n = 1, 14
Ul3 (m, n) = Ulall (3, m, n)
END DO
END DO
ENDDO
ENDDO
CALL invmat (14, Ul3, Ul3_inv, capel)
Ul3C (:,:) = CMPLX(Ul3 (:,:), 0.d0,kind=DP)
Ul3C_inv (:,:) = CMPLX(Ul3_inv (:,:), 0.d0,kind=DP)
!
Ul3C (:,:) = cmplx(Ul3 (:,:), 0.d0,kind=DP)
Ul3C_inv (:,:) = cmplx(Ul3_inv (:,:), 0.d0,kind=DP)
!
! randomly distributed points on a sphere
!
DO m = 1, maxm
@ -151,7 +151,7 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
rl (2, m) = randy () - 0.5d0
rl (3, m) = randy () - 0.5d0
rrl (m) = rl (1,m)**2 + rl (2,m)**2 + rl (3,m)**2
END DO
ENDDO
CALL ylmr2 ( maxlm, 2*maxl+1, rl, rrl, ylm )
!
! calculate complex spherical harmonics
@ -160,14 +160,14 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO l = 1, maxl
DO m = -l, l
ind = maxl + 1 + m
ind1 = l**2 + l + 1 + m
ind1 = l**2 + l + 1 + m
DO n2 = 1, 2*l+1
ind2 = l**2 + n2
IF (ABS(rot_ylm(ind,n2)).gt.1.d-8) &
IF (abs(rot_ylm(ind,n2))>1.d-8) &
ylm_compl(:,ind1) = ylm_compl(:,ind1) + rot_ylm(ind,n2)*ylm(:,ind2)
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
!
! invert Yl for each block of definite l (note the transpose operation)
!
@ -176,8 +176,8 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO m = 1, 3
DO n = 1, 3
yl1 (m, n) = ylm_compl (n, 1+m)
END DO
END DO
ENDDO
ENDDO
CALL invmat_complex (3, yl1, yl1_inv, capel)
!
! l = 2 block
@ -185,8 +185,8 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO m = 1, 5
DO n = 1, 5
yl2 (m, n) = ylm_compl (n, 4+m)
END DO
END DO
ENDDO
ENDDO
CALL invmat_complex (5, yl2, yl2_inv, capel)
!
! l = 3 block
@ -194,8 +194,8 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO m = 1, 7
DO n = 1, 7
yl3 (m, n) = ylm_compl (n, 9+m)
END DO
END DO
ENDDO
ENDDO
CALL invmat_complex (7, yl3, yl3_inv, capel)
!
! now for each symmetry operation of the point-group ...
@ -218,20 +218,20 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
ind1 = l**2 + l + 1 + m
DO n2 = 1, 2*l+1
ind2 = l**2 + n2
IF (ABS(rot_ylm(ind,n2)).gt.1.d-8) &
IF (abs(rot_ylm(ind,n2))>1.d-8) &
ylms_compl (:,ind1) = ylms_compl (:,ind1) &
+ rot_ylm (ind,n2) * ylms (:,ind2)
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
!
! l = 1 block => j=1/2 and j=3/2
! l = 1 block => j=1/2 and j=3/2
!
DO m = 1, 3
DO n = 1, 3
yl1 (m, n) = ylms_compl (n, 1+m)
END DO
END DO
ENDDO
ENDDO
dy1 (:, :, isym) = matmul (yl1 (:,:), yl1_inv (:,:))
DO m = 1, 3
DO n = 1, 3
@ -239,30 +239,30 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO n1 = 1, 2
dy112 (2*(m-1)+m1, 2*(n-1)+n1, isym) = dy1 (m, n, isym) &
* s_spin (m1, n1, isym)
END DO
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ENDDO
dy112 (:, :, isym) = matmul (dy112 (:,:,isym), Ul1C_inv (:,:))
dy112 (:, :, isym) = matmul (Ul1C (:,:), dy112 (:,:,isym))
DO m = 1, 2
DO n = 1, 2
dyj12 (m, n, isym) = CONJG(dy112 (n, m, isym))
END DO
END DO
dyj12 (m, n, isym) = conjg(dy112 (n, m, isym))
ENDDO
ENDDO
DO m = 1, 4
DO n = 1, 4
dyj32 (m ,n, isym) = CONJG(dy112 (2+n, 2+m, isym))
END DO
END DO
dyj32 (m ,n, isym) = conjg(dy112 (2+n, 2+m, isym))
ENDDO
ENDDO
!
! l = 3 block => j=5/2 and j=7/2
! l = 3 block => j=5/2 and j=7/2
!
DO m = 1, 7
DO n = 1, 7
yl3 (m, n) = ylms_compl (n, 9+m)
END DO
END DO
ENDDO
ENDDO
dy3 (:, :, isym) = matmul (yl3 (:,:), yl3_inv (:,:))
DO m = 1, 7
DO n = 1, 7
@ -270,86 +270,86 @@ SUBROUTINE d_matrix_so (dyj12, dyj32, dyj52, dyj72)
DO n1 = 1, 2
dy312 (2*(m-1)+m1, 2*(n-1)+n1, isym) = dy3 (m, n, isym) &
* s_spin (m1, n1, isym)
END DO
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ENDDO
dy312 (:, :, isym) = matmul (dy312 (:,:,isym), Ul3C_inv (:,:))
dy312 (:, :, isym) = matmul (Ul3C (:,:), dy312 (:,:,isym))
DO m = 1, 6
DO n = 1, 6
dyj52 (m, n, isym) = CONJG(dy312 (n, m, isym))
END DO
END DO
dyj52 (m, n, isym) = conjg(dy312 (n, m, isym))
ENDDO
ENDDO
DO m = 1, 8
DO n = 1, 8
dyj72 (m ,n, isym) = CONJG(dy312 (6+n, 6+m, isym))
END DO
END DO
dyj72 (m ,n, isym) = conjg(dy312 (6+n, 6+m, isym))
ENDDO
ENDDO
!
END DO
ENDDO
!
! check that D_S matrices are unitary as they should
! check that D_S matrices are unitary as they should
!
delta (:,:) = (0.d0,0.d0)
DO m= 1, 8
delta(m,m) = (1.d0,0.d0)
END DO
ENDDO
DO isym =1,nsym
!
! j = 1/2 block
!
capel = 0.d0
d12_con(:,:) = CONJG(dyj12 (:,:,isym))
d12_con(:,:) = conjg(dyj12 (:,:,isym))
DO m = 1, 2
DO n = 1, 2
capel = capel + &
ABS( ZDOTU(2, d12_con(1,m), 1, dyj12(1,n,isym), 1) - delta(m,n) )**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_so', &
abs( ZDOTU(2, d12_con(1,m), 1, dyj12(1,n,isym), 1) - delta(m,n) )**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_so', &
'D_S (j=1/2) for this symmetry operation is not unitary',isym)
!
! j = 3/2 block
!
capel = 0.d0
d32_con(:,:) = CONJG(dyj32 (:,:,isym))
d32_con(:,:) = conjg(dyj32 (:,:,isym))
DO m = 1, 4
DO n = 1, 4
capel = capel + &
ABS( ZDOTU(4, d32_con(1,m), 1, dyj32(1,n,isym), 1) - delta(m,n) )**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_so', &
abs( ZDOTU(4, d32_con(1,m), 1, dyj32(1,n,isym), 1) - delta(m,n) )**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_so', &
'D_S (j=3/2) for this symmetry operation is not unitary',isym)
!
! j = 5/2 block
!
capel = 0.d0
d52_con(:,:) = CONJG(dyj52 (:,:,isym))
d52_con(:,:) = conjg(dyj52 (:,:,isym))
DO m = 1, 6
DO n = 1, 6
capel = capel + &
ABS( ZDOTU(6, d52_con(1,m), 1, dyj52(1,n,isym), 1) - delta(m,n) )**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_so', &
abs( ZDOTU(6, d52_con(1,m), 1, dyj52(1,n,isym), 1) - delta(m,n) )**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_so', &
'D_S (j=5/2) for this symmetry operation is not unitary',isym)
!
! j = 7/2 block
!
capel = 0.d0
d72_con(:,:) = CONJG(dyj72 (:,:,isym))
d72_con(:,:) = conjg(dyj72 (:,:,isym))
DO m = 1, 8
DO n = 1, 8
capel = capel + &
ABS( ZDOTU(8, d72_con(1,m), 1, dyj72(1,n,isym), 1) - delta(m,n) )**2
END DO
END DO
IF (capel.gt.eps) CALL errore ('d_matrix_so', &
abs( ZDOTU(8, d72_con(1,m), 1, dyj72(1,n,isym), 1) - delta(m,n) )**2
ENDDO
ENDDO
IF (capel>eps) CALL errore ('d_matrix_so', &
'D_S (j=7/2) for this symmetry operation is not unitary',isym)
!
END DO
ENDDO
!
RETURN
!

104
PP/do_initial_state.f90
View File

@ -12,7 +12,7 @@ SUBROUTINE do_initial_state (excite)
!
! This routine is a driver routine which computes the initial state
! contribution to the core level shift.
!
!
! contains five parts which are computed by different routines:
! a) add_shift_lc, contribution due to the local potential
! b) add_shift_cc, contribution due to NLCC
@ -22,7 +22,7 @@ SUBROUTINE do_initial_state (excite)
!
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE cell_base, ONLY : at, bg, alat, omega
USE cell_base, ONLY : at, bg, alat, omega
USE ions_base, ONLY : nat, ntyp => nsp, ityp, tau, zv
USE gvect, ONLY : ngm, gstart, nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, &
ngl, nl, igtongl, g, gg, gcutm, eigts1, eigts2, eigts3
@ -43,8 +43,8 @@ SUBROUTINE do_initial_state (excite)
!
IMPLICIT NONE
!
integer :: excite(ntypx)
integer, allocatable :: ityp_gs(:), ityp_excited(:)
INTEGER :: excite(ntypx)
INTEGER, ALLOCATABLE :: ityp_gs(:), ityp_excited(:)
REAL(DP), ALLOCATABLE :: shift(:), &
shift_ef (:), &
shift_nl (:), &
@ -56,12 +56,12 @@ SUBROUTINE do_initial_state (excite)
!
! nonlocal, local, core-correction, ewald, and scf correction terms
REAL(DP) :: ryd_to_ev
parameter ( ryd_to_ev = 13.6058d0)
PARAMETER ( ryd_to_ev = 13.6058d0)
!
INTEGER :: ipol, na, nt, ik
! counter on polarization
! counter on atoms
logical :: first
LOGICAL :: first
!
CALL start_clock( 'do_shift' )
!
@ -70,26 +70,26 @@ SUBROUTINE do_initial_state (excite)
ALLOCATE ( ityp_gs(nat), ityp_excited(nat) )
ityp_gs(:) = ityp(:)
do nt =1,ntyp
if (excite(nt).lt.0 .or. excite(nt).gt.ntyp) &
call errore ('do_initial_state', ' wrong excite value ', nt )
end do
do nt=ntyp+1, ntypx
if (excite(nt).ne.0 ) &
call errore ('do_initial_state', ' cannot exicte nt>ntyp ', nt )
end do
DO nt =1,ntyp
IF (excite(nt)<0 .or. excite(nt)>ntyp) &
CALL errore ('do_initial_state', ' wrong excite value ', nt )
ENDDO
DO nt=ntyp+1, ntypx
IF (excite(nt)/=0 ) &
CALL errore ('do_initial_state', ' cannot exicte nt>ntyp ', nt )
ENDDO
ityp_gs(:) = ityp(:)
ityp_excited(:) = ityp(:)
do na=1,nat
if (excite(ityp(na)).ne.0) ityp_excited (na) = excite(ityp(na))
end do
DO na=1,nat
IF (excite(ityp(na))/=0) ityp_excited (na) = excite(ityp(na))
ENDDO
delta_zv(:) = 0.d0
do nt=1,ntyp
if (excite(nt).ne.0) delta_zv(nt) = zv(excite(nt)) - zv(nt)
end do
!
DO nt=1,ntyp
IF (excite(nt)/=0) delta_zv(nt) = zv(excite(nt)) - zv(nt)
ENDDO
!
shift_ef(:) = 0.D0
shift_nl(:) = 0.D0
shift_lc(:) = 0.D0
@ -100,12 +100,12 @@ SUBROUTINE do_initial_state (excite)
WRITE( stdout, '(/,5x,"INITIAL STATE CONTRIBUTION TO", &
& /,5x,"CORE LEVEL SHIFT ON ATOMS:", / )')
do na=1,nat
DO na=1,nat
shift_ef(na) = ef * delta_zv(ityp(na))
end do
ENDDO
first = .true.
10 continue
10 CONTINUE
!
! ... The nonlocal contribution is computed here
!
@ -123,51 +123,51 @@ SUBROUTINE do_initial_state (excite)
!
! ... The Hubbard contribution
!
IF ( lda_plus_u ) call errore('initial_state','LDA+U not implemented',1)
IF ( lda_plus_u ) CALL errore('initial_state','LDA+U not implemented',1)
!
! change atomic type and recompute needed quantities
!
if ( first ) then
IF ( first ) THEN
ityp(:) = ityp_excited(:)
call newd()
CALL newd()
nkb = 0
do na = 1, nat
DO na = 1, nat
nkb = nkb + nh (ityp(na))
enddo
deallocate(vkb)
if(nkb>0) allocate(vkb(npwx,nkb))
ENDDO
DEALLOCATE(vkb)
IF(nkb>0) ALLOCATE(vkb(npwx,nkb))
IF ( nks == 1 ) THEN
ik = 1
IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb )
END IF
ENDIF
shift_nl = - shift_nl
shift_lc = - shift_lc
shift_cc = - shift_cc
shift_hub= - shift_hub
first = .false.
goto 10
else
GOTO 10
ELSE
ityp(:) = ityp_gs(:)
call newd()
CALL newd()
nkb = 0
do na = 1, nat
DO na = 1, nat
nkb = nkb + nh (ityp(na))
enddo
deallocate(vkb)
if(nkb>0) allocate(vkb(npwx,nkb))
ENDDO
DEALLOCATE(vkb)
IF(nkb>0) ALLOCATE(vkb(npwx,nkb))
IF ( nks == 1 ) THEN
ik = 1
IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb )
END IF
end if
ENDIF
ENDIF
!
! ... The ionic contribution is computed here
!
! call infomsg ('do_initial_state',' EWALD term is still missing')
call do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
CALL do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
omega, g, gg, ngm, gcutm, gstart, gamma_only, shift_ion)
!
! ... here we sum all the contributions and compute the total force acting
@ -180,7 +180,7 @@ SUBROUTINE do_initial_state (excite)
shift_lc(na) + &
shift_cc(na) + &
shift_hub(na)
END DO
ENDDO
!
! ... resymmetrize (should not be needed, but ...)
!
@ -190,34 +190,34 @@ SUBROUTINE do_initial_state (excite)
!
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift(na), shift(na)*ryd_to_ev
enddo
ENDDO
WRITE (stdout,*)
#define DEBUG
#ifdef DEBUG
WRITE( stdout, '(5x,"The FERMI ENERGY contribution to shift")')
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift_ef(na), shift_ef(na)*ryd_to_ev
enddo
ENDDO
WRITE( stdout, '(5x,"The NON LOCAL contribution to shift")')
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift_nl(na), shift_nl(na)*ryd_to_ev
enddo
ENDDO
WRITE( stdout, '(5x,"The LOCAL contribution to shift")')
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift_lc(na), shift_lc(na)*ryd_to_ev
enddo
ENDDO
WRITE( stdout, '(5x,"The IONIC contribution to shift")')
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift_ion(na), shift_ion(na)*ryd_to_ev
enddo
ENDDO
WRITE( stdout, '(5x,"The CC contribution to shift")')
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift_cc(na), shift_cc(na)*ryd_to_ev
END DO
ENDDO
WRITE( stdout, '(5x,"The Hubbard contribution to shift")')
DO na = 1, nat
WRITE( stdout, 9035) na, ityp(na), shift_hub(na), shift_hub(na)*ryd_to_ev
END DO
ENDDO
#endif
!
DEALLOCATE( shift_ef, shift_nl, shift_lc, shift_cc, shift_hub, &

98
PP/do_shift_ew.f90
View File

@ -7,7 +7,7 @@
!
!
!-----------------------------------------------------------------------
subroutine do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
SUBROUTINE do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
omega, g, gg, ngm, gcutm, gstart, gamma_only, shift_ion)
!-----------------------------------------------------------------------
!
@ -19,19 +19,19 @@ subroutine do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
USE constants, ONLY : tpi, e2
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
implicit none
IMPLICIT NONE
!
! first the dummy variables
!
integer :: nat, ntyp, ityp (nat), ngm, gstart
INTEGER :: nat, ntyp, ityp (nat), ngm, gstart
! input: number of atoms in the unit cell
! input: number of different types of atoms
! input: the type of each atom
! input: number of plane waves for G sum
! input: first non-zero G vector
logical :: gamma_only
LOGICAL :: gamma_only
real(DP) :: tau (3, nat), g (3, ngm), gg (ngm), zv (ntyp), &
at (3, 3), bg (3, 3), omega, alat, gcutm, delta_zv(ntyp), &
@ -50,9 +50,9 @@ subroutine do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
!
! here the local variables
!
integer, parameter :: mxr = 50
INTEGER, PARAMETER :: mxr = 50
! the maximum number of R vectors included in r
integer :: ng, nr, na, nb, nt, nrm, ipol
INTEGER :: ng, nr, na, nb, nt, nrm, ipol
! counter over reciprocal G vectors
! counter over direct vectors
! counter on atoms
@ -74,106 +74,106 @@ subroutine do_shift_ew (alat, nat, ntyp, ityp, zv, delta_zv, at, bg, tau, &
! the maximum radius to consider real space sum
! buffer variable
! used to optimize alpha
complex(DP), allocatable :: rhon(:)
real(DP), external :: qe_erfc
COMPLEX(DP), ALLOCATABLE :: rhon(:)
real(DP), EXTERNAL :: qe_erfc
allocate (rhon(ngm))
ALLOCATE (rhon(ngm))
shift_ion(:) = 0.d0
tpiba2 = (tpi / alat) **2
charge = 0.d0
do na = 1, nat
DO na = 1, nat
charge = charge+zv (ityp (na) )
enddo
ENDDO
alpha = 2.9d0
100 alpha = alpha - 0.1d0
!
! choose alpha in order to have convergence in the sum over G
! upperbound is a safe upper bound for the error in the sum over G
!
if (alpha.le.0.d0) call errore ('do_shift_ew', 'optimal alpha not found', 1)
IF (alpha<=0.d0) CALL errore ('do_shift_ew', 'optimal alpha not found', 1)
upperbound = 2.d0 * charge**2 * sqrt (2.d0 * alpha / tpi) * qe_erfc ( &
sqrt (tpiba2 * gcutm / 4.d0 / alpha) )
if (upperbound.gt.1.0d-7) goto 100
IF (upperbound>1.0d-7) GOTO 100
!
! G-space sum here.
! Determine if this processor contains G=0 and set the constant term
!
if (gstart==2) then
do na =1,nat
IF (gstart==2) THEN
DO na =1,nat
shift_ion(na) = - charge * delta_zv(ityp(na)) /alpha/ 4.0d0
end do
endif
if (gamma_only) then
ENDDO
ENDIF
IF (gamma_only) THEN
fact = 2.d0
else
ELSE
fact = 1.d0
end if
do ng = gstart, ngm
ENDIF
DO ng = gstart, ngm
rhon(ng) = (0.d0, 0.d0)
do na =1, nat
DO na =1, nat
arg = (g (1, ng) * tau (1, na) + &
g (2, ng) * tau (2, na) + &
g (3, ng) * tau (3, na) ) * tpi
rhon(ng) = rhon(ng) + zv (ityp(na)) * CMPLX(cos (arg), -sin (arg),kind=DP)
enddo
end do
do na=1,nat
do ng=gstart, ngm
rhon(ng) = rhon(ng) + zv (ityp(na)) * cmplx(cos (arg), -sin (arg),kind=DP)
ENDDO
ENDDO
DO na=1,nat
DO ng=gstart, ngm
arg = (g (1, ng) * tau (1, na) + g (2, ng) * tau (2, na) &
+ g (3, ng) * tau (3, na) ) * tpi
shift_ion(na) = shift_ion(na) + fact * delta_zv(ityp(na)) * &
CONJG(rhon(ng)) * CMPLX(cos (arg), -sin (arg),kind=DP) * &
conjg(rhon(ng)) * cmplx(cos (arg), -sin (arg),kind=DP) * &
exp ( -gg(ng)*tpiba2/alpha/4.d0) / gg(ng)/tpiba2
enddo
enddo
ENDDO
ENDDO
shift_ion(:) = 2.d0 * tpi / omega * shift_ion(:)
!
! Here add the other constant term
!
if (gstart.eq.2) then
do na = 1, nat
IF (gstart==2) THEN
DO na = 1, nat
shift_ion(na) = shift_ion(na) - &
zv (ityp (na) ) * delta_zv(ityp(na)) * &
sqrt (8.d0/tpi*alpha)
enddo
endif
ENDDO
ENDIF
!
! R-space sum here (only for the processor that contains G=0)
!
if (gstart.eq.2) then
IF (gstart==2) THEN
rmax = 4.d0 / sqrt (alpha) / alat
!
! with this choice terms up to ZiZj*erfc(4) are counted (erfc(4)=2x10^-8
!
do na = 1, nat
do nb = 1, nat
do ipol = 1, 3
DO na = 1, nat
DO nb = 1, nat
DO ipol = 1, 3
dtau (ipol) = tau (ipol, na) - tau (ipol, nb)
enddo
ENDDO
!
! generates nearest-neighbors shells
!
call rgen (dtau, rmax, mxr, at, bg, r, r2, nrm)
CALL rgen (dtau, rmax, mxr, at, bg, r, r2, nrm)
!
! and sum to the real space part
!
do nr = 1, nrm
DO nr = 1, nrm
rr = sqrt (r2 (nr) ) * alat
shift_ion(na) = shift_ion(na) + &
delta_zv(ityp(na)) * zv (ityp (nb) ) * &
qe_erfc ( sqrt (alpha) * rr) / rr
enddo
enddo
enddo
endif
ENDDO
ENDDO
ENDDO
ENDIF
shift_ion(:) = e2 * shift_ion(:)
call mp_sum ( shift_ion, intra_pool_comm )
CALL mp_sum ( shift_ion, intra_pool_comm )
deallocate (rhon)
return
end subroutine do_shift_ew
DEALLOCATE (rhon)
RETURN
END SUBROUTINE do_shift_ew

48
PP/dos.f90
View File

@ -40,7 +40,7 @@ PROGRAM dos
! Gaussian broadening is used in all other cases:
! - if degauss is set to some value in namelist &inputpp, that value
! (and the optional value for ngauss) is used
! - if degauss is NOT set to any value in namelist &inputpp, the
! - if degauss is NOT set to any value in namelist &inputpp, the
! value of degauss and of ngauss are read from the input data
! file (they will be the same used in the pw.x calculations)
! - if degauss is NOT set to any value in namelist &inputpp, AND
@ -82,7 +82,7 @@ PROGRAM dos
! set default values for variables in namelist
!
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
IF ( trim( outdir ) == ' ' ) outdir = './'
prefix ='pwscf'
fildos =' '
Emin =-1000000.d0
@ -100,10 +100,10 @@ PROGRAM dos
degauss1 = degauss
ngauss1 = ngauss
!
END IF
ENDIF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios /= 0 ) CALL errore('dos','reading inputpp namelist',ABS(ios))
IF ( ios /= 0 ) CALL errore('dos','reading inputpp namelist',abs(ios))
!
! ... Broadcast variables
!
@ -114,19 +114,19 @@ PROGRAM dos
!
IF ( ionode ) THEN
!
IF (nks.NE.nkstot) &
IF (nks/=nkstot) &
CALL errore ('dos', 'pools not implemented, or incorrect file read', 1)
!
IF (degauss1.NE.0.d0) THEN
IF (degauss1/=0.d0) THEN
degauss=degauss1
ngauss =ngauss1
WRITE( stdout,'(/5x,"Gaussian broadening (read from input): ",&
& "ngauss,degauss=",i4,f12.6/)') ngauss,degauss
ltetra=.FALSE.
lgauss=.TRUE.
ELSE IF (ltetra) THEN
ltetra=.false.
lgauss=.true.
ELSEIF (ltetra) THEN
WRITE( stdout,'(/5x,"Tetrahedra used"/)')
ELSE IF (lgauss) THEN
ELSEIF (lgauss) THEN
WRITE( stdout,'(/5x,"Gaussian broadening (read from file): ",&
& "ngauss,degauss=",i4,f12.6/)') ngauss,degauss
ELSE
@ -134,36 +134,36 @@ PROGRAM dos
ngauss =0
WRITE( stdout,'(/5x,"Gaussian broadening (default values): ",&
& "ngauss,degauss=",i4,f12.6/)') ngauss,degauss
ltetra=.FALSE.
lgauss=.TRUE.
END IF
ltetra=.false.
lgauss=.true.
ENDIF
!
! find band extrema
!
Elw = et (1, 1)
Eup = et (nbnd, 1)
DO ik = 2, nks
Elw = MIN (Elw, et (1, ik) )
Eup = MAX (Eup, et (nbnd, ik) )
Elw = min (Elw, et (1, ik) )
Eup = max (Eup, et (nbnd, ik) )
ENDDO
IF (degauss.NE.0.d0) THEN
IF (degauss/=0.d0) THEN
Eup = Eup + 3.d0 * degauss
Elw = Elw - 3.d0 * degauss
ENDIF
!
Emin=MAX(Emin/rytoev,Elw)
Emax=MIN(Emax/rytoev,Eup)
Emin=max(Emin/rytoev,Elw)
Emax=min(Emax/rytoev,Eup)
DeltaE = DeltaE / rytoev
ndos = NINT ( (Emax - Emin) / DeltaE+0.500001d0)
ndos = nint ( (Emax - Emin) / DeltaE+0.500001d0)
DOSint = 0.d0
!
IF ( fildos == ' ' ) fildos = TRIM(prefix)//'.dos'
IF ( fildos == ' ' ) fildos = trim(prefix)//'.dos'
OPEN (unit = 4, file = fildos, status = 'unknown', form = 'formatted')
IF (nspin.EQ.1.OR.nspin.EQ.4) THEN
IF (nspin==1.or.nspin==4) THEN
WRITE(4,'("# E (eV) dos(E) Int dos(E)")')
ELSE
WRITE(4,'("# E (eV) dosup(E) dosdw(E) Int dos(E)")')
END IF
ENDIF
DO n= 1, ndos
E = Emin + (n - 1) * DeltaE
IF (ltetra) THEN
@ -171,7 +171,7 @@ PROGRAM dos
ELSE
CALL dos_g(et,nspin,nbnd, nks,wk,degauss,ngauss, E, DOSofE)
ENDIF
IF (nspin.EQ.1.OR.nspin.EQ.4) THEN
IF (nspin==1.or.nspin==4) THEN
DOSint = DOSint + DOSofE (1) * DeltaE
WRITE (4, '(f7.3,2e12.4)') E * rytoev, DOSofE(1)/rytoev, DOSint
ELSE
@ -182,7 +182,7 @@ PROGRAM dos
CLOSE (unit = 4)
!
END IF
ENDIF
!
CALL stop_pp
!

44
PP/dosg.f90
View File

@ -7,44 +7,44 @@
!
!
!--------------------------------------------------------------------
subroutine dos_g (et, nspin, nbnd, nks, wk, Degauss, ngauss, E, dosg)
SUBROUTINE dos_g (et, nspin, nbnd, nks, wk, Degauss, ngauss, E, dosg)
!--------------------------------------------------------------------
!
USE kinds, only : DP
implicit none
integer :: nspin, nks, nbnd, ngauss
USE kinds, ONLY : DP
IMPLICIT NONE
INTEGER :: nspin, nks, nbnd, ngauss
real(DP) :: wk (nks), et (nbnd, nks), Degauss, E, dosg (2)
real(DP) :: w0gauss
integer :: n, ns, nk0, nk, ik
integer :: nspin0
external w0gauss
INTEGER :: n, ns, nk0, nk, ik
INTEGER :: nspin0
EXTERNAL w0gauss
!
if (nspin == 1 .or. nspin == 4) then
IF (nspin == 1 .or. nspin == 4) THEN
nk = nks
else
ELSE
nk = nks / 2
endif
ENDIF
nspin0=nspin
if (nspin==4) nspin0=1
IF (nspin==4) nspin0=1
!
do ns = 1, nspin0
if (ns.eq.1) then
DO ns = 1, nspin0
IF (ns==1) THEN
nk0 = 1
else
ELSE
nk0 = nks / 2 + 1
endif
ENDIF
dosg (ns) = 0.0d0
do ik = nk0, nk0 + nk-1
do n = 1, nbnd
DO ik = nk0, nk0 + nk-1
DO n = 1, nbnd
dosg (ns) = dosg (ns) + wk (ik) * w0gauss ( (E-et (n, ik) ) &
/ Degauss, ngauss)
enddo
enddo
ENDDO
ENDDO
!
dosg (ns) = dosg (ns) / Degauss
!
enddo
ENDDO
!
return
end subroutine dos_g
RETURN
END SUBROUTINE dos_g

128
PP/elf.f90
View File

@ -6,7 +6,7 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine do_elf (elf)
SUBROUTINE do_elf (elf)
!-----------------------------------------------------------------------
!
! calculatation of the electron localization function
@ -47,140 +47,140 @@ subroutine do_elf (elf)
!
! I/O variables
!
implicit none
IMPLICIT NONE
real(DP) :: elf (nrxx)
!
! local variables
!
integer :: i, j, k, ibnd, ik, is
INTEGER :: i, j, k, ibnd, ik, is
real(DP) :: gv(3), w1, d, fac
real(DP), allocatable :: kkin (:), tbos (:)
complex(DP), allocatable :: aux (:), aux2 (:)
real(DP), ALLOCATABLE :: kkin (:), tbos (:)
COMPLEX(DP), ALLOCATABLE :: aux (:), aux2 (:)
!
call infomsg ('do_elf', 'elf + US not fully implemented')
CALL infomsg ('do_elf', 'elf + US not fully implemented')
!
allocate (kkin( nrxx))
allocate (aux ( nrxxs))
ALLOCATE (kkin( nrxx))
ALLOCATE (aux ( nrxxs))
aux(:) = (0.d0,0.d0)
kkin(:) = 0.d0
!
! Calculates local kinetic energy, stored in kkin
!
do ik = 1, nks
DO ik = 1, nks
!
! prepare the indices of this k point
!
call gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
!
! reads the eigenfunctions
!
call davcio (evc, nwordwfc, iunwfc, ik, - 1)
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
!
do ibnd = 1, nbnd
do j = 1, 3
DO ibnd = 1, nbnd
DO j = 1, 3
aux(:) = (0.d0,0.d0)
w1 = wg (ibnd, ik) / omega
do i = 1, npw
DO i = 1, npw
gv (j) = (xk (j, ik) + g (j, igk (i) ) ) * tpiba
aux (nls(igk (i) ) ) = CMPLX(0d0, gv (j) ,kind=DP) * evc (i, ibnd)
aux (nls(igk (i) ) ) = cmplx(0d0, gv (j) ,kind=DP) * evc (i, ibnd)
IF (gamma_only) THEN
aux (nlsm(igk (i) ) ) = CMPLX(0d0, -gv (j) ,kind=DP) * &
CONJG ( evc (i, ibnd) )
END IF
enddo
call cft3s (aux, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
do i = 1, nrxxs
kkin(i) = kkin(i) + w1 * (DBLE(aux(i))**2 + AIMAG(aux(i))**2)
enddo
aux (nlsm(igk (i) ) ) = cmplx(0d0, -gv (j) ,kind=DP) * &
conjg ( evc (i, ibnd) )
ENDIF
ENDDO
CALL cft3s (aux, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
DO i = 1, nrxxs
kkin(i) = kkin(i) + w1 * (dble(aux(i))**2 + aimag(aux(i))**2)
ENDDO
! j
enddo
ENDDO
! ibnd
enddo
ENDDO
! ik
enddo
ENDDO
#ifdef __PARA
!
! reduce local kinetic energy across pools
!
call mp_sum( kkin, inter_pool_comm )
CALL mp_sum( kkin, inter_pool_comm )
#endif
!
! interpolate the local kinetic energy to the dense grid
! Note that for US PP this term is incomplete: it contains
! only the contribution from the smooth part of the wavefunction
!
if (doublegrid) then
deallocate (aux)
allocate(aux(nrxx))
call interpolate (kkin, kkin, 1)
end if
IF (doublegrid) THEN
DEALLOCATE (aux)
ALLOCATE(aux(nrxx))
CALL interpolate (kkin, kkin, 1)
ENDIF
!
! symmetrize the local kinetic energy if needed
!
IF ( .NOT. gamma_only) THEN
IF ( .not. gamma_only) THEN
!
CALL sym_rho_init ( gamma_only )
CALL sym_rho_init ( gamma_only )
!
aux(:) = CMPLX ( kkin (:), 0.0_dp, KIND=dp)
aux(:) = cmplx ( kkin (:), 0.0_dp, kind=dp)
CALL cft3s (aux, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, -1)
ALLOCATE (aux2(ngm))
ALLOCATE (aux2(ngm))
aux2(:) = aux(nl(:))
!
! aux2 contains the local kinetic energy in G-space to be symmetrized
!
CALL sym_rho ( 1, aux2 )
CALL sym_rho ( 1, aux2 )
!
aux(:) = (0.0_dp, 0.0_dp)
aux(nl(:)) = aux2(:)
DEALLOCATE (aux2)
CALL cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
kkin (:) = DBLE(aux(:))
kkin (:) = dble(aux(:))
!
END IF
ENDIF
!
! Calculate the bosonic kinetic density, stored in tbos
! aux --> charge density in Fourier space
! aux2 --> iG * rho(G)
!
allocate ( tbos(nrxx), aux2(nrxx) )
ALLOCATE ( tbos(nrxx), aux2(nrxx) )
tbos(:) = 0.d0
!
! put the total (up+down) charge density in rho%of_r(*,1)
!
do is = 2, nspin
DO is = 2, nspin
rho%of_r (:, 1) = rho%of_r (:, 1) + rho%of_r (:, is)
enddo
ENDDO
!
aux(:) = CMPLX( rho%of_r(:, 1), 0.d0 ,kind=DP)
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
aux(:) = cmplx( rho%of_r(:, 1), 0.d0 ,kind=DP)
CALL cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
do j = 1, 3
DO j = 1, 3
aux2(:) = (0.d0,0.d0)
do i = 1, ngm
aux2(nl(i)) = aux(nl(i)) * CMPLX(0.0d0, g(j,i)*tpiba,kind=DP)
enddo
DO i = 1, ngm
aux2(nl(i)) = aux(nl(i)) * cmplx(0.0d0, g(j,i)*tpiba,kind=DP)
ENDDO
IF (gamma_only) THEN
do i = 1, ngm
aux2(nlm(i)) = aux(nlm(i)) * CMPLX(0.0d0,-g(j,i)*tpiba,kind=DP)
enddo
END IF
DO i = 1, ngm
aux2(nlm(i)) = aux(nlm(i)) * cmplx(0.0d0,-g(j,i)*tpiba,kind=DP)
ENDDO
ENDIF
call cft3 (aux2, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
do i = 1, nrxx
tbos (i) = tbos (i) + DBLE(aux2(i))**2
enddo
enddo
CALL cft3 (aux2, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
DO i = 1, nrxx
tbos (i) = tbos (i) + dble(aux2(i))**2
ENDDO
ENDDO
!
! Calculates ELF
!
fac = 5.d0 / (3.d0 * (3.d0 * pi**2) ** (2.d0 / 3.d0) )
elf(:) = 0.d0
do i = 1, nrxx
if (rho%of_r (i,1) > 1.d-30) then
DO i = 1, nrxx
IF (rho%of_r (i,1) > 1.d-30) THEN
d = fac / rho%of_r(i,1)**(5d0/3d0) * (kkin(i)-0.25d0*tbos(i)/rho%of_r(i,1))
elf (i) = 1.0d0 / (1.0d0 + d**2)
endif
enddo
deallocate (aux, aux2, tbos, kkin)
return
end subroutine do_elf
ENDIF
ENDDO
DEALLOCATE (aux, aux2, tbos, kkin)
RETURN
END SUBROUTINE do_elf

454
PP/epsilon.f90
View File

File diff suppressed because it is too large Load Diff

30
PP/ggen1d.f90
View File

@ -5,7 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
subroutine ggen1d (ngm1d, g1d, gg1d, ig1dto3d, nl1d, igtongl1d)
SUBROUTINE ggen1d (ngm1d, g1d, gg1d, ig1dto3d, nl1d, igtongl1d)
!
! This subroutine is the one dimensional equivalent of the ggen
! routine. It is used to produce the G vectors in the z directions
@ -15,8 +15,8 @@ subroutine ggen1d (ngm1d, g1d, gg1d, ig1dto3d, nl1d, igtongl1d)
USE kinds, ONLY: DP
USE cell_base, ONLY : at
USE gvect, ONLY: nr3, ngm, g, gg, igtongl
implicit none
integer :: ngm1d, ig1dto3d (nr3), igtongl1d (nr3), nl1d (nr3)
IMPLICIT NONE
INTEGER :: ngm1d, ig1dto3d (nr3), igtongl1d (nr3), nl1d (nr3)
! output: the number of 1D G vectors on this processor
! output: correspondence 1D with 3D G vectors
! output: the correspondence with the shells
@ -29,35 +29,35 @@ subroutine ggen1d (ngm1d, g1d, gg1d, ig1dto3d, nl1d, igtongl1d)
! local variables
!
integer :: ig, ig1d
INTEGER :: ig, ig1d
! counter on 3D vectors
! counter on 1D vectors
real(DP), parameter :: eps = 1.d-12
real(DP), PARAMETER :: eps = 1.d-12
g1d(:,:) = 0.d0
gg1d(:) = 0.d0
ig1d = 0
do ig = 1, ngm
if ( (abs(g(1,ig)).lt.eps) .and. (abs(g(2,ig)) .lt.eps) ) then
DO ig = 1, ngm
IF ( (abs(g(1,ig))<eps) .and. (abs(g(2,ig)) <eps) ) THEN
!
! a vector of the 1D grid has been found
!
ig1d = ig1d+1
if (ig1d.gt.nr3) call errore ('ggen1d', 'too many G', 1)
IF (ig1d>nr3) CALL errore ('ggen1d', 'too many G', 1)
g1d (3, ig1d) = g (3, ig)
gg1d (ig1d) = gg (ig)
ig1dto3d (ig1d) = ig
nl1d (ig1d) = nint (g (3, ig) * at (3, 3) ) + 1
if (nl1d (ig1d) .lt.1) nl1d (ig1d) = nl1d (ig1d) + nr3
endif
enddo
IF (nl1d (ig1d) <1) nl1d (ig1d) = nl1d (ig1d) + nr3
ENDIF
ENDDO
ngm1d = ig1d
do ig1d = 1, ngm1d
DO ig1d = 1, ngm1d
igtongl1d (ig1d) = igtongl (ig1dto3d (ig1d) )
enddo
return
end subroutine ggen1d
ENDDO
RETURN
END SUBROUTINE ggen1d

16
PP/hexspinsym.f90
View File

@ -8,13 +8,13 @@
!-----------------------------------------------------------------------
SUBROUTINE hexspinsym(d_spin)
!-----------------------------------------------------------------------
!
! Provides symmetry operations in the spin space for Hexagonal and
!
! Provides symmetry operations in the spin space for Hexagonal and
! Trigonal lattices.
! The c axis is assumed to be along the z axis
!
!
USE kinds
!
USE kinds
USE symm_base, ONLY : nsym, sname
!
IMPLICIT NONE
@ -29,7 +29,7 @@ SUBROUTINE hexspinsym(d_spin)
!
! sin3 = sin(pi/3), cos3 = cos(pi/3), msin3 = -sin(pi/3), mcos3 = -sin(pi/3)
!
REAL(DP), parameter :: sin3 = 0.866025403784438597d0, cos3 = 0.5d0, &
REAL(DP), PARAMETER :: sin3 = 0.866025403784438597d0, cos3 = 0.5d0, &
msin3 =-0.866025403784438597d0, mcos3 = -0.5d0
!
! and the local variables
@ -38,7 +38,7 @@ SUBROUTINE hexspinsym(d_spin)
!
! symmetry matrices in the j=1/2 subspace
!
INTEGER :: i,j
INTEGER :: i,j
!
! counter over the rotations
! counter over the rotations
@ -82,7 +82,7 @@ SUBROUTINE hexspinsym(d_spin)
(0.d0,0.d0), (cos3,msin3), (mcos3,msin3), (0.d0,0.d0), &
(0.d0,0.d0), (mcos3,msin3), (cos3,msin3), (0.d0,0.d0), &
(0.d0,0.d0), (sin3,mcos3), (msin3,mcos3), (0.d0,0.d0), &
(0.d0,0.d0), (msin3,mcos3), (sin3,mcos3), (0.d0,0.d0), &
(0.d0,0.d0), (msin3,mcos3), (sin3,mcos3), (0.d0,0.d0), &
(-1.d0,0.d0), (0.d0,0.d0), (0.d0,0.d0), (-1.d0,0.d0), &
(0.d0,-1.d0), (0.d0,0.d0), (0.d0,0.d0), (0.d0,1.d0), &
(0.d0,0.d0), (1.d0,0.d0), (-1.d0,0.d0), (0.d0,0.d0), &
@ -105,5 +105,5 @@ SUBROUTINE hexspinsym(d_spin)
ENDDO
ENDDO
RETURN
!
!
END SUBROUTINE hexspinsym

90
PP/initial_state.f90
View File

@ -1,22 +1,22 @@
!
! Copyright (C) 2001-2009 Quantum ESPRESSO group
! Copyright (C) 2001-2009 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
PROGRAM initial_state
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! compute forces on atoms as a post-process
!
! input: namelist "&inputpp", with variables
! prefix prefix of input files saved by program pwscf
! outdir temporary directory where files resides
!
!
! input: namelist "&inputpp", with variables
! prefix prefix of input files saved by program pwscf
! outdir temporary directory where files resides
!
USE io_global, ONLY : stdout, ionode, ionode_id
USE kinds, ONLY : DP
USE kinds, ONLY : DP
USE io_files, ONLY : prefix, tmp_dir, iunwfc, nwordwfc, trimcheck
USE ions_base, ONLY : nat
USE klist, ONLY : nks, xk
@ -28,65 +28,65 @@ PROGRAM initial_state
USE mp_global, ONLY : mp_startup
USE environment,ONLY : environment_start
!
IMPLICIT NONE
CHARACTER(len=256) :: outdir
IMPLICIT NONE
CHARACTER(len=256) :: outdir
INTEGER :: ios, ik, excite(ntypx)
NAMELIST / inputpp / outdir, prefix, excite
!
!
! initialise environment
!
#ifdef __PARA
CALL mp_startup ( )
#endif
CALL environment_start ( 'initstate' )
!
! set default values for variables in namelist
!
!
! set default values for variables in namelist
!
excite(:) = 0
prefix = 'pwscf'
prefix = 'pwscf'
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
!
IF ( trim( outdir ) == ' ' ) outdir = './'
!
ios = 0
!
IF ( ionode ) THEN
IF ( ionode ) THEN
!
CALL input_from_file ( )
!
READ (5, inputpp, iostat = ios)
!
tmp_dir = trimcheck (outdir)
!
END IF
!
READ (5, inputpp, iostat = ios)
!
tmp_dir = trimcheck (outdir)
!
ENDIF
!
CALL mp_bcast ( ios, ionode_id )
!
IF ( ios /= 0) &
CALL errore ('postforces', 'reading inputpp namelist', ABS (ios) )
CALL errore ('postforces', 'reading inputpp namelist', abs (ios) )
!
! ... Broadcast variables
!
CALL mp_bcast( tmp_dir, ionode_id )
CALL mp_bcast( prefix, ionode_id )
! ... Broadcast variables
!
CALL mp_bcast( tmp_dir, ionode_id )
CALL mp_bcast( prefix, ionode_id )
CALL mp_bcast( excite, ionode_id )
!
! Now allocate space for pwscf variables, read and check them.
!
CALL read_file
!
! Now allocate space for pwscf variables, read and check them.
!
CALL read_file
CALL openfil_pp
CALL hinit0
CALL hinit1
IF ( nks == 1 ) THEN
CALL hinit0
CALL hinit1
IF ( nks == 1 ) THEN
ik = 1
CALL davcio( evc, nwordwfc, iunwfc, ik, -1 )
IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb )
END IF
ENDIF
!CALL sum_band
!
!CALL sum_band
!
CALL do_initial_state (excite)
!
CALL stop_pp
!
!
CALL stop_pp
!
END PROGRAM initial_state

460
PP/local_dos.f90
View File

@ -7,7 +7,7 @@
!
!
!--------------------------------------------------------------------
subroutine local_dos (iflag, lsign, kpoint, kband, spin_component, &
SUBROUTINE local_dos (iflag, lsign, kpoint, kband, spin_component, &
emin, emax, dos)
!--------------------------------------------------------------------
!
@ -47,96 +47,96 @@ subroutine local_dos (iflag, lsign, kpoint, kband, spin_component, &
USE mp, ONLY : mp_bcast, mp_sum
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
USE becmod, ONLY : calbec
implicit none
IMPLICIT NONE
!
! input variables
!
integer, intent(in) :: iflag, kpoint, kband, spin_component
logical, intent(in) :: lsign
real(DP), intent(in) :: emin, emax
INTEGER, INTENT(in) :: iflag, kpoint, kband, spin_component
LOGICAL, INTENT(in) :: lsign
real(DP), INTENT(in) :: emin, emax
!
real(DP), intent(out) :: dos (nrxx)
real(DP), INTENT(out) :: dos (nrxx)
!
! local variables
!
integer :: ikb, jkb, ijkb0, ih, jh, kh, na, ijh, np
INTEGER :: ikb, jkb, ijkb0, ih, jh, kh, na, ijh, np
! counters for US PPs
integer :: ir, is, ig, ibnd, ik, irm, isup, isdw, ipol, kkb, is1, is2
INTEGER :: ir, is, ig, ibnd, ik, irm, isup, isdw, ipol, kkb, is1, is2
! counters
real(DP) :: w, w1, modulus
real(DP), allocatable :: rbecp(:,:), segno(:), maxmod(:)
complex(DP), allocatable :: becp(:,:), &
real(DP), ALLOCATABLE :: rbecp(:,:), segno(:), maxmod(:)
COMPLEX(DP), ALLOCATABLE :: becp(:,:), &
becp_nc(:,:,:), be1(:,:), be2(:,:)
integer :: who_calculate, iproc
complex(DP) :: phase
real(DP), external :: w0gauss, w1gauss
logical :: i_am_the_pool
integer :: which_pool, kpoint_pool
INTEGER :: who_calculate, iproc
COMPLEX(DP) :: phase
real(DP), EXTERNAL :: w0gauss, w1gauss
LOGICAL :: i_am_the_pool
INTEGER :: which_pool, kpoint_pool
!
! input checks
!
if (noncolin.and. lsign) call errore('local_dos','not available',1)
if (noncolin.and. gamma_only) call errore('local_dos','not available',1)
IF (noncolin.and. lsign) CALL errore('local_dos','not available',1)
IF (noncolin.and. gamma_only) CALL errore('local_dos','not available',1)
!
if ( (iflag == 0) .and. ( kband < 1 .or. kband > nbnd ) ) &
call errore ('local_dos', 'wrong band specified', 1)
if ( (iflag == 0) .and. ( kpoint < 1 .or. kpoint > nkstot ) ) &
call errore ('local_dos', 'wrong kpoint specified', 1)
if (lsign) then
if (iflag /= 0) call errore ('local_dos', 'inconsistent flags', 1)
if (sqrt(xk(1,kpoint)**2+xk(2,kpoint)**2+xk(3,kpoint)**2) > 1d-9 ) &
call errore ('local_dos', 'k must be zero', 1)
end if
IF ( (iflag == 0) .and. ( kband < 1 .or. kband > nbnd ) ) &
CALL errore ('local_dos', 'wrong band specified', 1)
IF ( (iflag == 0) .and. ( kpoint < 1 .or. kpoint > nkstot ) ) &
CALL errore ('local_dos', 'wrong kpoint specified', 1)
IF (lsign) THEN
IF (iflag /= 0) CALL errore ('local_dos', 'inconsistent flags', 1)
IF (sqrt(xk(1,kpoint)**2+xk(2,kpoint)**2+xk(3,kpoint)**2) > 1d-9 ) &
CALL errore ('local_dos', 'k must be zero', 1)
ENDIF
!
if (gamma_only) then
allocate (rbecp(nkb,nbnd))
else
if (noncolin) then
allocate (becp_nc(nkb,npol,nbnd))
if (lspinorb) then
allocate(be1(nhm,2))
allocate(be2(nhm,2))
endif
else
allocate (becp(nkb,nbnd))
endif
endif
IF (gamma_only) THEN
ALLOCATE (rbecp(nkb,nbnd))
ELSE
IF (noncolin) THEN
ALLOCATE (becp_nc(nkb,npol,nbnd))
IF (lspinorb) THEN
ALLOCATE(be1(nhm,2))
ALLOCATE(be2(nhm,2))
ENDIF
ELSE
ALLOCATE (becp(nkb,nbnd))
ENDIF
ENDIF
rho%of_r(:,:) = 0.d0
dos(:) = 0.d0
becsum(:,:,:) = 0.d0
if (lsign) allocate(segno(nrxx))
IF (lsign) ALLOCATE(segno(nrxx))
!
! calculate the correct weights
!
if (iflag /= 0 .and. .not.lgauss) call errore ('local_dos', &
IF (iflag /= 0 .and. .not.lgauss) CALL errore ('local_dos', &
'gaussian broadening needed', 1)
if (iflag == 2 .and. ngauss /= -99) call errore ('local_dos', &
IF (iflag == 2 .and. ngauss /= -99) CALL errore ('local_dos', &
' beware: not using Fermi-Dirac function ', - ngauss)
do ik = 1, nks
do ibnd = 1, nbnd
if (iflag == 0) then
DO ik = 1, nks
DO ibnd = 1, nbnd
IF (iflag == 0) THEN
wg (ibnd, ik) = 0.d0
elseif (iflag == 1) then
ELSEIF (iflag == 1) THEN
wg (ibnd, ik) = wk (ik) * w0gauss ( (ef - et (ibnd, ik) ) &
/ degauss, ngauss) / degauss
elseif (iflag == 2) then
ELSEIF (iflag == 2) THEN
wg (ibnd, ik) = - wk (ik) * w1gauss ( (ef - et (ibnd, ik) ) &
/ degauss, ngauss)
elseif (iflag == 3) then
if (et (ibnd, ik) <= emax .and. et (ibnd, ik) >= emin) then
ELSEIF (iflag == 3) THEN
IF (et (ibnd, ik) <= emax .and. et (ibnd, ik) >= emin) THEN
wg (ibnd, ik) = wk (ik)
else
ELSE
wg (ibnd, ik) = 0.d0
endif
else
call errore ('local_dos', ' iflag not allowed', abs (iflag) )
endif
enddo
enddo
ENDIF
ELSE
CALL errore ('local_dos', ' iflag not allowed', abs (iflag) )
ENDIF
ENDDO
ENDDO
IF (npool>1) THEN
CALL xk_pool( kpoint, nkstot, kpoint_pool, which_pool )
if (kpoint_pool<1 .or. kpoint_pool> nks) &
IF (kpoint_pool<1 .or. kpoint_pool> nks) &
CALL errore('local_dos','problems with xk_pool',1)
i_am_the_pool=(my_pool_id==which_pool)
ELSE
@ -144,288 +144,288 @@ subroutine local_dos (iflag, lsign, kpoint, kband, spin_component, &
kpoint_pool=kpoint
ENDIF
if (iflag == 0.and.i_am_the_pool) wg (kband, kpoint_pool) = 1.d0
IF (iflag == 0.and.i_am_the_pool) wg (kband, kpoint_pool) = 1.d0
!
! here we sum for each k point the contribution
! of the wavefunctions to the density of states
!
do ik = 1, nks
if (ik == kpoint_pool .and.i_am_the_pool.or. iflag /= 0) then
if (lsda) current_spin = isk (ik)
call gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
call davcio (evc, nwordwfc, iunwfc, ik, - 1)
call init_us_2 (npw, igk, xk (1, ik), vkb)
DO ik = 1, nks
IF (ik == kpoint_pool .and.i_am_the_pool.or. iflag /= 0) THEN
IF (lsda) current_spin = isk (ik)
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
CALL init_us_2 (npw, igk, xk (1, ik), vkb)
if (gamma_only) then
call calbec ( npw, vkb, evc, rbecp )
else if (noncolin) then
call calbec ( npw, vkb, evc, becp_nc )
else
call calbec ( npw, vkb, evc, becp )
end if
IF (gamma_only) THEN
CALL calbec ( npw, vkb, evc, rbecp )
ELSEIF (noncolin) THEN
CALL calbec ( npw, vkb, evc, becp_nc )
ELSE
CALL calbec ( npw, vkb, evc, becp )
ENDIF
!
! here we compute the density of states
!
do ibnd = 1, nbnd
if (ibnd == kband .or. iflag /= 0) then
if (noncolin) then
DO ibnd = 1, nbnd
IF (ibnd == kband .or. iflag /= 0) THEN
IF (noncolin) THEN
psic_nc = (0.d0,0.d0)
do ig = 1, npw
DO ig = 1, npw
psic_nc(nls(igk(ig)),1)=evc(ig ,ibnd)
psic_nc(nls(igk(ig)),2)=evc(ig+npwx,ibnd)
enddo
do ipol=1,npol
call cft3s (psic_nc(1,ipol),nr1s,nr2s,nr3s, &
ENDDO
DO ipol=1,npol
CALL cft3s (psic_nc(1,ipol),nr1s,nr2s,nr3s, &
nrx1s,nrx2s,nrx3s,2)
enddo
else
ENDDO
ELSE
psic(1:nrxxs) = (0.d0,0.d0)
do ig = 1, npw
DO ig = 1, npw
psic (nls (igk (ig) ) ) = evc (ig, ibnd)
enddo
if (gamma_only) then
do ig = 1, npw
psic (nlsm(igk (ig) ) ) = CONJG(evc (ig, ibnd))
enddo
end if
call cft3s (psic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
endif
ENDDO
IF (gamma_only) THEN
DO ig = 1, npw
psic (nlsm(igk (ig) ) ) = conjg(evc (ig, ibnd))
ENDDO
ENDIF
CALL cft3s (psic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
ENDIF
w1 = wg (ibnd, ik) / omega
!
! Compute and save the sign of the wavefunction at the gamma point
!
if (lsign) then
if (gamma_only) then
IF (lsign) THEN
IF (gamma_only) THEN
! psi(r) is real by construction
segno(1:nrxxs) = DBLE(psic(1:nrxxs))
else
segno(1:nrxxs) = dble(psic(1:nrxxs))
ELSE
! determine the phase factor that makes psi(r) real.
allocate(maxmod(nproc_pool))
ALLOCATE(maxmod(nproc_pool))
maxmod(me_pool+1)=0.0_DP
do ir = 1, nrxxs
DO ir = 1, nrxxs
modulus=abs(psic(ir))
if (modulus > maxmod(me_pool+1)) then
IF (modulus > maxmod(me_pool+1)) THEN
irm=ir
maxmod(me_pool+1)=modulus
endif
enddo
ENDIF
ENDDO
who_calculate=1
#ifdef __PARA
call mp_sum(maxmod,intra_pool_comm)
do iproc=2,nproc_pool
if (maxmod(iproc)>maxmod(who_calculate)) &
CALL mp_sum(maxmod,intra_pool_comm)
DO iproc=2,nproc_pool
IF (maxmod(iproc)>maxmod(who_calculate)) &
who_calculate=iproc
enddo
ENDDO
#endif
if (maxmod(who_calculate) < 1.d-10) &
call errore('local_dos','zero wavefunction',1)
IF (maxmod(who_calculate) < 1.d-10) &
CALL errore('local_dos','zero wavefunction',1)
IF (me_pool+1==who_calculate) &
phase = psic(irm)/maxmod(who_calculate)
deallocate(maxmod)
DEALLOCATE(maxmod)
#ifdef __PARA
call mp_bcast(phase,who_calculate-1,intra_pool_comm)
CALL mp_bcast(phase,who_calculate-1,intra_pool_comm)
#endif
segno(1:nrxxs) = DBLE( psic(1:nrxxs)*CONJG(phase) )
endif
if (doublegrid) call interpolate (segno, segno, 1)
segno(1:nrxxs) = dble( psic(1:nrxxs)*conjg(phase) )
ENDIF
IF (doublegrid) CALL interpolate (segno, segno, 1)
segno(:) = sign( 1.d0, segno(:) )
endif
ENDIF
!
if (noncolin) then
do ipol=1,npol
do ir=1,nrxxs
IF (noncolin) THEN
DO ipol=1,npol
DO ir=1,nrxxs
rho%of_r(ir,current_spin)=rho%of_r(ir,current_spin)+&
w1*(DBLE(psic_nc(ir,ipol))**2+ &
AIMAG(psic_nc(ir,ipol))**2)
enddo
enddo
else
do ir=1,nrxxs
w1*(dble(psic_nc(ir,ipol))**2+ &
aimag(psic_nc(ir,ipol))**2)
ENDDO
ENDDO
ELSE
DO ir=1,nrxxs
rho%of_r(ir,current_spin)=rho%of_r(ir,current_spin) + &
w1 * (DBLE( psic (ir) ) **2 + AIMAG (psic (ir) ) **2)
enddo
endif
w1 * (dble( psic (ir) ) **2 + aimag (psic (ir) ) **2)
ENDDO
ENDIF
!
! If we have a US pseudopotential we compute here the becsum term
!
w1 = wg (ibnd, ik)
ijkb0 = 0
do np = 1, ntyp
if (upf(np)%tvanp ) then
do na = 1, nat
if (ityp (na) == np) then
if (noncolin) then
if (upf(np)%has_so) then
DO np = 1, ntyp
IF (upf(np)%tvanp ) THEN
DO na = 1, nat
IF (ityp (na) == np) THEN
IF (noncolin) THEN
IF (upf(np)%has_so) THEN
be1=(0.d0,0.d0)
be2=(0.d0,0.d0)
do ih = 1, nh(np)
DO ih = 1, nh(np)
ikb = ijkb0 + ih
do kh = 1, nh(np)
if ((nhtol(kh,np).eq.nhtol(ih,np)).and. &
(nhtoj(kh,np).eq.nhtoj(ih,np)).and. &
(indv(kh,np).eq.indv(ih,np))) then
DO kh = 1, nh(np)
IF ((nhtol(kh,np)==nhtol(ih,np)).and. &
(nhtoj(kh,np)==nhtoj(ih,np)).and. &
(indv(kh,np)==indv(ih,np))) THEN
kkb=ijkb0 + kh
do is1=1,2
do is2=1,2
DO is1=1,2
DO is2=1,2
be1(ih,is1)=be1(ih,is1)+ &
fcoef(ih,kh,is1,is2,np)* &
becp_nc(kkb,is2,ibnd)
be2(ih,is1)=be2(ih,is1)+ &
fcoef(kh,ih,is2,is1,np)* &
CONJG(becp_nc(kkb,is2,ibnd))
enddo
enddo
endif
enddo
enddo
endif
conjg(becp_nc(kkb,is2,ibnd))
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
ENDIF
ijh = 1
do ih = 1, nh (np)
DO ih = 1, nh (np)
ikb = ijkb0 + ih
if (upf(np)%has_so) then
IF (upf(np)%has_so) THEN
becsum(ijh,na,1)=becsum(ijh,na,1)+ w1* &
(be1(ih,1)*be2(ih,1)+be1(ih,2)*be2(ih,2))
else
ELSE
becsum(ijh,na,1) = becsum(ijh,na,1)+ &
w1*(CONJG(becp_nc(ikb,1,ibnd))* &
w1*(conjg(becp_nc(ikb,1,ibnd))* &
becp_nc(ikb,1,ibnd)+ &
CONJG(becp_nc(ikb,2,ibnd))* &
conjg(becp_nc(ikb,2,ibnd))* &
becp_nc(ikb,2,ibnd))
endif
ENDIF
ijh = ijh + 1
do jh = ih + 1, nh (np)
DO jh = ih + 1, nh (np)
jkb = ijkb0 + jh
if (upf(np)%has_so) then
IF (upf(np)%has_so) THEN
becsum(ijh,na,1)=becsum(ijh,na,1) &
+ w1*((be1(jh,1)*be2(ih,1)+ &
be1(jh,2)*be2(ih,2))+ &
(be1(ih,1)*be2(jh,1)+ &
be1(ih,2)*be2(jh,2)) )
else
ELSE
becsum(ijh,na,1)= becsum(ijh,na,1)+ &
w1*2.d0*DBLE(CONJG(becp_nc(ikb,1,ibnd)) &
w1*2.d0*dble(conjg(becp_nc(ikb,1,ibnd)) &
*becp_nc(jkb,1,ibnd) + &
CONJG(becp_nc(ikb,2,ibnd)) &
conjg(becp_nc(ikb,2,ibnd)) &
*becp_nc(jkb,2,ibnd) )
endif
ENDIF
ijh = ijh + 1
enddo
enddo
else
ENDDO
ENDDO
ELSE
ijh = 1
do ih = 1, nh (np)
DO ih = 1, nh (np)
ikb = ijkb0 + ih
if (gamma_only) then
IF (gamma_only) THEN
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + w1 * &
rbecp(ikb,ibnd)*rbecp(ikb,ibnd)
else
ELSE
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + w1 * &
DBLE(CONJG(becp(ikb,ibnd))*becp(ikb,ibnd))
end if
dble(conjg(becp(ikb,ibnd))*becp(ikb,ibnd))
ENDIF
ijh = ijh + 1
do jh = ih + 1, nh (np)
DO jh = ih + 1, nh (np)
jkb = ijkb0 + jh
if (gamma_only) then
IF (gamma_only) THEN
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + 2.d0*w1 * &
rbecp(ikb,ibnd)*rbecp(jkb,ibnd)
else
ELSE
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + 2.d0*w1 * &
DBLE(CONJG(becp(ikb,ibnd))*becp(jkb,ibnd))
endif
dble(conjg(becp(ikb,ibnd))*becp(jkb,ibnd))
ENDIF
ijh = ijh + 1
enddo
enddo
endif
ENDDO
ENDDO
ENDIF
ijkb0 = ijkb0 + nh (np)
endif
enddo
else
do na = 1, nat
if (ityp (na) == np) ijkb0 = ijkb0 + nh (np)
enddo
endif
enddo
endif
enddo
endif
enddo
if (gamma_only) then
deallocate(rbecp)
else
if (noncolin) then
if (lspinorb) then
deallocate(be1)
deallocate(be2)
endif
deallocate(becp_nc)
else
deallocate(becp)
endif
endif
if (doublegrid) then
if (noncolin) then
call interpolate(rho%of_r, rho%of_r, 1)
else
do is = 1, nspin
call interpolate(rho%of_r(1, is), rho%of_r(1, is), 1)
enddo
endif
endif
ENDIF
ENDDO
ELSE
DO na = 1, nat
IF (ityp (na) == np) ijkb0 = ijkb0 + nh (np)
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
IF (gamma_only) THEN
DEALLOCATE(rbecp)
ELSE
IF (noncolin) THEN
IF (lspinorb) THEN
DEALLOCATE(be1)
DEALLOCATE(be2)
ENDIF
DEALLOCATE(becp_nc)
ELSE
DEALLOCATE(becp)
ENDIF
ENDIF
IF (doublegrid) THEN
IF (noncolin) THEN
CALL interpolate(rho%of_r, rho%of_r, 1)
ELSE
DO is = 1, nspin
CALL interpolate(rho%of_r(1, is), rho%of_r(1, is), 1)
ENDDO
ENDIF
ENDIF
!
! Here we add the US contribution to the charge
!
call addusdens(rho%of_r(:,:))
CALL addusdens(rho%of_r(:,:))
!
if (nspin == 1 .or. nspin==4) then
is = 1
IF (nspin == 1 .or. nspin==4) THEN
is = 1
dos(:) = rho%of_r (:, is)
else
IF ( iflag==3 .AND. (spin_component==1 .OR. spin_component==2 ) ) THEN
ELSE
IF ( iflag==3 .and. (spin_component==1 .or. spin_component==2 ) ) THEN
dos(:) = rho%of_r (:, spin_component)
ELSE
isup = 1
isdw = 2
dos(:) = rho%of_r (:, isup) + rho%of_r (:, isdw)
END IF
end if
if (lsign) then
ENDIF
ENDIF
IF (lsign) THEN
dos(:) = dos(:) * segno(:)
deallocate(segno)
endif
DEALLOCATE(segno)
ENDIF
#ifdef __PARA
call mp_sum( dos, inter_pool_comm )
CALL mp_sum( dos, inter_pool_comm )
#endif
if (iflag == 0 .OR. gamma_only) return
IF (iflag == 0 .or. gamma_only) RETURN
!
! symmetrization of the local dos
!
call sym_rho_init ( gamma_only )
CALL sym_rho_init ( gamma_only )
!
psic(:) = CMPLX ( dos(:), 0.0_dp, KIND=dp)
call cft3s (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, -1)
rho%of_g(:,1) = psic(nl(:))
psic(:) = cmplx ( dos(:), 0.0_dp, kind=dp)
CALL cft3s (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, -1)
rho%of_g(:,1) = psic(nl(:))
!
call sym_rho (1, rho%of_g)
CALL sym_rho (1, rho%of_g)
!
psic(:) = (0.0_dp, 0.0_dp)
psic(nl(:)) = rho%of_g(:,1)
call cft3s (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
dos(:) = DBLE(psic(:))
CALL cft3s (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
dos(:) = dble(psic(:))
!
return
RETURN
end subroutine local_dos
END SUBROUTINE local_dos
!------------------------------------------------------------------------
SUBROUTINE xk_pool( ik, nkstot, ik_pool, which_pool )
!------------------------------------------------------------------------
!
! This routine is a simplified version of set_kpoint_vars in
! This routine is a simplified version of set_kpoint_vars in
! xml_io_files. It recieves the index ik of a k_point in the complete
! k point list and return the index within the pool ik_pool, and
! the number of the pool that has that k point.
@ -435,8 +435,8 @@ USE mp_global, ONLY : npool, kunit
!
IMPLICIT NONE
INTEGER, INTENT(IN) :: ik, nkstot
INTEGER, INTENT(OUT) :: ik_pool, which_pool
INTEGER, INTENT(in) :: ik, nkstot
INTEGER, INTENT(out) :: ik_pool, which_pool
!
INTEGER :: nkl, nkr, nkbl
!
@ -449,7 +449,7 @@ ENDIF
!
! ... find out number of k points blocks
!
nkbl = nkstot / kunit
nkbl = nkstot / kunit
!
! ... k points per pool
!
@ -462,7 +462,7 @@ nkr = ( nkstot - nkl * npool ) / kunit
! ... calculate the pool and the index within the pool
!
IF (ik<=nkr*(nkl+1)) THEN
which_pool=(ik-1)/(nkl+1)
which_pool=(ik-1)/(nkl+1)
ik_pool=ik-which_pool*(nkl+1)
ELSE
which_pool=nkr+(ik-nkr*(nkl+1)-1)/nkl

204
PP/local_dos1d.f90
View File

@ -8,7 +8,7 @@
!
!
!--------------------------------------------------------------------
subroutine local_dos1d (ik, kband, plan)
SUBROUTINE local_dos1d (ik, kband, plan)
!--------------------------------------------------------------------
!
! calculates |psi|^2 for band kband at point ik
@ -25,11 +25,11 @@ subroutine local_dos1d (ik, kband, plan)
USE spin_orb, ONLY: lspinorb, fcoef
USE wavefunctions_module, ONLY: evc, psic, psic_nc
USE becmod, ONLY: bec_type, becp
implicit none
IMPLICIT NONE
!
! input variables
!
integer :: ik, kband
INTEGER :: ik, kband
! input: the k point
! input: the band
@ -39,7 +39,7 @@ subroutine local_dos1d (ik, kband, plan)
! Additional local variables for Ultrasoft PP's
!
integer :: ikb, jkb, ijkb0, ih, jh, na, ijh, ipol, np
INTEGER :: ikb, jkb, ijkb0, ih, jh, na, ijh, ipol, np
! counter on beta functions
! counter on beta functions
! auxiliary variable for ijkb0
@ -51,7 +51,7 @@ subroutine local_dos1d (ik, kband, plan)
!
! And here the local variables
!
integer :: ir, ig, ibnd, is1, is2, kkb, kh
INTEGER :: ir, ig, ibnd, is1, is2, kkb, kh
! counter on 3D r points
! counter on spin polarizations
! counter on g vectors
@ -59,18 +59,18 @@ subroutine local_dos1d (ik, kband, plan)
real(DP) :: w1
! the weight of one k point
real(DP), allocatable :: aux (:)
real(DP), ALLOCATABLE :: aux (:)
! auxiliary for rho
complex(DP), allocatable :: prho (:), be1(:,:), be2(:,:)
COMPLEX(DP), ALLOCATABLE :: prho (:), be1(:,:), be2(:,:)
! complex charge for fft
allocate (prho(nrxx))
allocate (aux(nrxx))
if (lspinorb) then
allocate(be1(nhm,2))
allocate(be2(nhm,2))
endif
ALLOCATE (prho(nrxx))
ALLOCATE (aux(nrxx))
IF (lspinorb) THEN
ALLOCATE(be1(nhm,2))
ALLOCATE(be2(nhm,2))
ENDIF
aux(:) = 0.d0
becsum(:,:,:) = 0.d0
@ -81,35 +81,35 @@ subroutine local_dos1d (ik, kband, plan)
! First compute the square modulus of the state kband,ik on the smooth
! mesh
!
if (noncolin) then
IF (noncolin) THEN
psic_nc = (0.d0,0.d0)
do ig = 1, npw
DO ig = 1, npw
psic_nc (nls (igk (ig) ), 1 ) = evc (ig , kband)
psic_nc (nls (igk (ig) ), 2 ) = evc (ig+npwx, kband)
enddo
do ipol=1,npol
call cft3s (psic_nc(1,ipol), nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
enddo
ENDDO
DO ipol=1,npol
CALL cft3s (psic_nc(1,ipol), nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
ENDDO
w1 = wg (kband, ik) / omega
do ipol=1,npol
do ir = 1, nrxxs
aux(ir) = aux(ir) + w1 * ( DBLE(psic_nc(ir,ipol))**2 + &
AIMAG(psic_nc(ir,ipol))**2 )
enddo
enddo
else
DO ipol=1,npol
DO ir = 1, nrxxs
aux(ir) = aux(ir) + w1 * ( dble(psic_nc(ir,ipol))**2 + &
aimag(psic_nc(ir,ipol))**2 )
ENDDO
ENDDO
ELSE
psic(1:nrxxs) = (0.d0,0.d0)
do ig = 1, npw
DO ig = 1, npw
psic (nls (igk (ig) ) ) = evc (ig, kband)
enddo
call cft3s (psic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
ENDDO
CALL cft3s (psic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
w1 = wg (kband, ik) / omega
do ir = 1, nrxxs
aux(ir) = aux(ir) + w1 * (DBLE(psic(ir))**2 + AIMAG(psic(ir))**2)
enddo
endif
DO ir = 1, nrxxs
aux(ir) = aux(ir) + w1 * (dble(psic(ir))**2 + aimag(psic(ir))**2)
ENDDO
ENDIF
!
! If we have a US pseudopotential we compute here the becsum term
@ -118,113 +118,113 @@ subroutine local_dos1d (ik, kband, plan)
w1 = wg (ibnd, ik)
ijkb0 = 0
do np = 1, ntyp
if (upf(np)%tvanp) then
do na = 1, nat
if (ityp (na) == np) then
if (noncolin) then
if (upf(np)%has_so) then
DO np = 1, ntyp
IF (upf(np)%tvanp) THEN
DO na = 1, nat
IF (ityp (na) == np) THEN
IF (noncolin) THEN
IF (upf(np)%has_so) THEN
be1=(0.d0,0.d0)
be2=(0.d0,0.d0)
do ih = 1, nh(np)
DO ih = 1, nh(np)
ikb = ijkb0 + ih
do kh = 1, nh(np)
if ((nhtol(kh,np).eq.nhtol(ih,np)).and. &
(nhtoj(kh,np).eq.nhtoj(ih,np)).and. &
(indv(kh,np).eq.indv(ih,np))) then
DO kh = 1, nh(np)
IF ((nhtol(kh,np)==nhtol(ih,np)).and. &
(nhtoj(kh,np)==nhtoj(ih,np)).and. &
(indv(kh,np)==indv(ih,np))) THEN
kkb=ijkb0 + kh
do is1=1,2
do is2=1,2
DO is1=1,2
DO is2=1,2
be1(ih,is1)=be1(ih,is1)+ &
fcoef(ih,kh,is1,is2,np)* &
becp%nc(kkb,is2,ibnd)
be2(ih,is1)=be2(ih,is1)+ &
fcoef(kh,ih,is2,is1,np)* &
CONJG(becp%nc(kkb,is2,ibnd))
enddo
enddo
endif
enddo
enddo
endif
endif
conjg(becp%nc(kkb,is2,ibnd))
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
ENDIF
ENDIF
ijh = 1
do ih = 1, nh (np)
DO ih = 1, nh (np)
ikb = ijkb0 + ih
if (noncolin) then
if (upf(np)%has_so) then
IF (noncolin) THEN
IF (upf(np)%has_so) THEN
becsum(ijh,na,1)=becsum(ijh,na,1)+ w1* &
(be1(ih,1)*be2(ih,1)+be1(ih,2)*be2(ih,2))
else
do ipol=1,npol
ELSE
DO ipol=1,npol
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + w1 * &
DBLE( CONJG(becp%nc(ikb,ipol,ibnd)) * &
dble( conjg(becp%nc(ikb,ipol,ibnd)) * &
becp%nc(ikb,ipol,ibnd) )
enddo
endif
else
ENDDO
ENDIF
ELSE
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + w1 * &
DBLE( CONJG(becp%k(ikb,ibnd)) * becp%k(ikb,ibnd) )
endif
dble( conjg(becp%k(ikb,ibnd)) * becp%k(ikb,ibnd) )
ENDIF
ijh = ijh + 1
do jh = ih + 1, nh (np)
DO jh = ih + 1, nh (np)
jkb = ijkb0 + jh
if (noncolin) then
if (upf(np)%has_so) then
IF (noncolin) THEN
IF (upf(np)%has_so) THEN
becsum(ijh,na,1)=becsum(ijh,na,1) &
+ w1*((be1(jh,1)*be2(ih,1)+ &
be1(jh,2)*be2(ih,2))+ &
(be1(ih,1)*be2(jh,1)+ &
be1(ih,2)*be2(jh,2)) )
else
do ipol=1,npol
ELSE
DO ipol=1,npol
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + w1 * 2.d0 * &
DBLE( CONJG(becp%nc(ikb,ipol,ibnd)) &
dble( conjg(becp%nc(ikb,ipol,ibnd)) &
* becp%nc(jkb,ipol,ibnd) )
enddo
endif
else
ENDDO
ENDIF
ELSE
becsum(ijh,na,current_spin) = &
becsum(ijh,na,current_spin) + w1 * 2.d0 * &
DBLE( CONJG(becp%k(ikb,ibnd)) * becp%k(jkb,ibnd) )
endif
dble( conjg(becp%k(ikb,ibnd)) * becp%k(jkb,ibnd) )
ENDIF
ijh = ijh + 1
enddo
enddo
ENDDO
ENDDO
ijkb0 = ijkb0 + nh (np)
endif
enddo
else
do na = 1, nat
if (ityp (na) .eq.np) ijkb0 = ijkb0 + nh (np)
enddo
endif
enddo
ENDIF
ENDDO
ELSE
DO na = 1, nat
IF (ityp (na) ==np) ijkb0 = ijkb0 + nh (np)
ENDDO
ENDIF
ENDDO
!
! Interpolate on the thick mesh and pass to reciprocal space
!
if (doublegrid) then
call interpolate (aux, aux, 1)
endif
do ir = 1, nrxx
prho (ir) = CMPLX(aux (ir), 0.d0,kind=DP)
enddo
call cft3 (prho, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
IF (doublegrid) THEN
CALL interpolate (aux, aux, 1)
ENDIF
DO ir = 1, nrxx
prho (ir) = cmplx(aux (ir), 0.d0,kind=DP)
ENDDO
CALL cft3 (prho, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
! Here we add the US contribution to the charge for the atoms which n
! it. Or compute the planar average in the NC case.
!
call addusdens1d (plan, prho)
CALL addusdens1d (plan, prho)
!
deallocate (aux)
deallocate (prho)
if (lspinorb) then
deallocate(be1)
deallocate(be2)
endif
DEALLOCATE (aux)
DEALLOCATE (prho)
IF (lspinorb) THEN
DEALLOCATE(be1)
DEALLOCATE(be2)
ENDIF
!
return
end subroutine local_dos1d
RETURN
END SUBROUTINE local_dos1d

114
PP/local_dos_mag.f90
View File

@ -12,12 +12,12 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
!
! ... calculates the symmetrized charge density and sum of occupied
! ... eigenvalues.
! ... this version works also for metals (gaussian spreading technique)
! ... this version works also for metals (gaussian spreading technique)
!
USE kinds, ONLY : DP
USE ions_base, ONLY : nat, ntyp => nsp, ityp
USE cell_base, ONLY : omega,tpiba2
USE gvect, ONLY : nrxx, ngm, g, ecutwfc
USE gvect, ONLY : nrxx, ngm, g, ecutwfc
USE gsmooth, ONLY : nls, nr1s, nr2s, nr3s, &
nrx1s, nrx2s, nrx3s, nrxxs, doublegrid
USE klist, ONLY : nks, xk
@ -39,13 +39,13 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
REAL(DP) :: raux(nrxx)
INTEGER :: ikb, jkb, ijkb0, ih, jh, ijh, na, np
! counters on beta functions, atoms, pseudopotentials
! counters on beta functions, atoms, pseudopotentials
INTEGER :: ir, is, ig, ibnd, ik
! counter on 3D r points
! counter on spin polarizations
! counter on g vectors
! counter on bands
! counter on k points
! counter on k points
!
REAL(DP) :: w1
! weights
@ -76,37 +76,37 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
!
DO ibnd = 1, nbnd
!
IF (ibnd == kband) then
IF (ibnd == kband) THEN
psic_nc = (0.D0,0.D0)
DO ig = 1, npw
psic_nc(nls(igk(ig)),1)=evc(ig ,ibnd)
psic_nc(nls(igk(ig)),2)=evc(ig+npwx,ibnd)
END DO
ENDDO
DO ipol=1,npol
call cft3s (psic_nc(1,ipol), nr1s, nr2s, nr3s, nrx1s, &
CALL cft3s (psic_nc(1,ipol), nr1s, nr2s, nr3s, nrx1s, &
nrx2s, nrx3s, 2)
END DO
ENDDO
IF (spin_component==1) THEN
DO ir = 1,nrxxs
rho%of_r(ir,2) = rho%of_r(ir,2) + 2.D0*w1* &
(DBLE(psic_nc(ir,1))* DBLE(psic_nc(ir,2)) + &
AIMAG(psic_nc(ir,1))*AIMAG(psic_nc(ir,2)))
END DO
END IF
(dble(psic_nc(ir,1))* dble(psic_nc(ir,2)) + &
aimag(psic_nc(ir,1))*aimag(psic_nc(ir,2)))
ENDDO
ENDIF
IF (spin_component==2) THEN
DO ir = 1,nrxxs
rho%of_r(ir,3) = rho%of_r(ir,3) + 2.D0*w1* &
(DBLE(psic_nc(ir,1))*AIMAG(psic_nc(ir,2)) - &
DBLE(psic_nc(ir,2))*AIMAG(psic_nc(ir,1)))
END DO
END IF
(dble(psic_nc(ir,1))*aimag(psic_nc(ir,2)) - &
dble(psic_nc(ir,2))*aimag(psic_nc(ir,1)))
ENDDO
ENDIF
IF (spin_component==3) THEN
DO ir = 1,nrxxs
rho%of_r(ir,4) = rho%of_r(ir,4) + w1* &
(DBLE(psic_nc(ir,1))**2+AIMAG(psic_nc(ir,1))**2 &
-DBLE(psic_nc(ir,2))**2-AIMAG(psic_nc(ir,2))**2)
END DO
END IF
(dble(psic_nc(ir,1))**2+aimag(psic_nc(ir,1))**2 &
-dble(psic_nc(ir,2))**2-aimag(psic_nc(ir,2))**2)
ENDDO
ENDIF
ijkb0 = 0
DO np = 1, ntyp
@ -123,8 +123,8 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
DO ih = 1, nh(np)
ikb = ijkb0 + ih
DO kh = 1, nh(np)
IF ((nhtol(kh,np)==nhtol(ih,np)).AND. &
(nhtoj(kh,np)==nhtoj(ih,np)).AND. &
IF ((nhtol(kh,np)==nhtol(ih,np)).and. &
(nhtoj(kh,np)==nhtoj(ih,np)).and. &
(indv(kh,np)==indv(ih,np))) THEN
kkb=ijkb0 + kh
DO is1=1,2
@ -134,13 +134,13 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
becp_nc(kkb,is2,ibnd)
be2(ih,is1)=be2(ih,is1)+ &
fcoef(kh,ih,is2,is1,np)* &
CONJG(becp_nc(kkb,is2,ibnd))
END DO
END DO
END IF
END DO
END DO
END IF
conjg(becp_nc(kkb,is2,ibnd))
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
ENDIF
ijh = 1
!
DO ih = 1, nh(np)
@ -153,7 +153,7 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
(be1(ih,2)*be2(ih,1)+ be1(ih,1)*be2(ih,2))
IF (spin_component==2) &
becsum(ijh,na,3)=becsum(ijh,na,3)+ &
(0.d0,-1.d0)* &
(0.d0,-1.d0)* &
(be1(ih,2)*be2(ih,1)-be1(ih,1)*be2(ih,2))
IF (spin_component==3) &
becsum(ijh,na,4)=becsum(ijh,na,4)+ &
@ -161,21 +161,21 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
ELSE
IF (spin_component==1) &
becsum(ijh,na,2)=becsum(ijh,na,2) &
+ (CONJG(becp_nc(ikb,2,ibnd)) &
+ (conjg(becp_nc(ikb,2,ibnd)) &
*becp_nc(ikb,1,ibnd) &
+ CONJG(becp_nc(ikb,1,ibnd)) &
+ conjg(becp_nc(ikb,1,ibnd)) &
*becp_nc(ikb,2,ibnd) )
IF (spin_component==2) &
becsum(ijh,na,3)=becsum(ijh,na,3)+2.d0 &
*AIMAG(CONJG(becp_nc(ikb,1,ibnd))* &
*aimag(conjg(becp_nc(ikb,1,ibnd))* &
becp_nc(ikb,2,ibnd) )
IF (spin_component==3) &
becsum(ijh,na,4) = becsum(ijh,na,4) &
+ ( CONJG(becp_nc(ikb,1,ibnd)) &
+ ( conjg(becp_nc(ikb,1,ibnd)) &
*becp_nc(ikb,1,ibnd) &
- CONJG(becp_nc(ikb,2,ibnd)) &
- conjg(becp_nc(ikb,2,ibnd)) &
*becp_nc(ikb,2,ibnd) )
END IF
ENDIF
!
ijh = ijh + 1
!
@ -202,36 +202,36 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
ELSE
IF (spin_component==1) &
becsum(ijh,na,2)=becsum(ijh,na,2)+ 2.d0* &
DBLE(CONJG(becp_nc(ikb,2,ibnd))* &
dble(conjg(becp_nc(ikb,2,ibnd))* &
becp_nc(jkb,1,ibnd) + &
CONJG(becp_nc(ikb,1,ibnd))* &
conjg(becp_nc(ikb,1,ibnd))* &
becp_nc(jkb,2,ibnd) )
IF (spin_component==2) &
becsum(ijh,na,3)=becsum(ijh,na,3)+ &
2.d0* &
AIMAG(CONJG(becp_nc(ikb,1,ibnd))* &
aimag(conjg(becp_nc(ikb,1,ibnd))* &
becp_nc(jkb,2,ibnd) + &
CONJG(becp_nc(ikb,1,ibnd))* &
conjg(becp_nc(ikb,1,ibnd))* &
becp_nc(jkb,2,ibnd) )
IF (spin_component==3) &
becsum(ijh,na,4)=becsum(ijh,na,4)+ 2.d0* &
DBLE(CONJG(becp_nc(ikb,1,ibnd))* &
dble(conjg(becp_nc(ikb,1,ibnd))* &
becp_nc(jkb,1,ibnd) - &
CONJG(becp_nc(ikb,2,ibnd))* &
conjg(becp_nc(ikb,2,ibnd))* &
becp_nc(jkb,2,ibnd) )
END IF
!
ENDIF
!
ijh = ijh + 1
!
END DO
ENDDO
!
END DO
ENDDO
!
ijkb0 = ijkb0 + nh(np)
!
END IF
ENDIF
!
END DO
ENDDO
!
ELSE
!
@ -239,24 +239,24 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
!
IF ( ityp(na) == np ) ijkb0 = ijkb0 + nh(np)
!
END DO
ENDDO
!
END IF
ENDIF
!
END DO
ENDDO
!
END IF
ENDIF
!
END DO
ENDDO
!
END IF
ENDIF
!
END DO
ENDDO
!
IF ( doublegrid ) THEN
is=spin_component+1
CALL interpolate( rho%of_r(1,is), rho%of_r(1,is), 1 )
END IF
ENDIF
!
! ... Here we add the Ultrasoft contribution to the charge and magnetization
!
@ -264,7 +264,7 @@ SUBROUTINE local_dos_mag(spin_component, kpoint, kband, raux)
DO ir=1,nrxx
raux(ir)=rho%of_r(ir,spin_component+1)
END DO
ENDDO
!
IF (lspinorb) DEALLOCATE(be1, be2)
DEALLOCATE( becp_nc )

8
PP/openfil_pp.f90
View File

@ -15,7 +15,7 @@ SUBROUTINE openfil_pp()
!
USE kinds, ONLY : DP
USE wvfct, ONLY : nbnd, npwx
use control_flags, ONLY: twfcollect
USE control_flags, ONLY: twfcollect
USE io_files, ONLY : prefix, iunwfc, nwordwfc, diropn
USE noncollin_module, ONLY : npol
!
@ -32,9 +32,9 @@ SUBROUTINE openfil_pp()
!
CALL diropn( iunwfc, 'wfc', nwordwfc, exst )
!
IF ( .NOT. exst ) THEN
call errore ('openfil_pp','file '//TRIM( prefix )//'.wfc'//' not found',1)
END IF
IF ( .not. exst ) THEN
CALL errore ('openfil_pp','file '//trim( prefix )//'.wfc'//' not found',1)
ENDIF
!
RETURN
!

28
PP/paw_postproc.f90
View File

@ -22,7 +22,7 @@ SUBROUTINE PAW_make_ae_charge(rho)
USE gvect, ONLY : nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx
USE cell_base, ONLY : at, bg, alat
TYPE(scf_type), INTENT(INOUT) :: rho
TYPE(scf_type), INTENT(inout) :: rho
TYPE(paw_info) :: i ! minimal info on atoms
INTEGER :: ipol ! counter on x,y,z
INTEGER :: ir ! counter on grid point
@ -38,9 +38,9 @@ SUBROUTINE PAW_make_ae_charge(rho)
! Some initialization
!
inv_nr1 = 1.D0 / DBLE( nr1 )
inv_nr2 = 1.D0 / DBLE( nr2 )
inv_nr3 = 1.D0 / DBLE( nr3 )
inv_nr1 = 1.D0 / dble( nr1 )
inv_nr2 = 1.D0 / dble( nr2 )
inv_nr3 = 1.D0 / dble( nr3 )
!
! I cannot parallelize on atoms, because it is already parallelized
! on charge slabs
@ -104,7 +104,7 @@ SUBROUTINE PAW_make_ae_charge(rho)
DEALLOCATE(d1y, d2y)
!
#if defined (__PARA)
idx0 = nrx1*nrx2 * SUM ( dfftp%npp(1:me_pool) )
idx0 = nrx1*nrx2 * sum ( dfftp%npp(1:me_pool) )
#else
idx0 = 0
#endif
@ -122,17 +122,17 @@ SUBROUTINE PAW_make_ae_charge(rho)
IF ( l >= nr1 .or. j >= nr2 .or. k >= nr3 ) CYCLE rsp_point
!
DO ipol = 1, 3
posi(ipol) = DBLE( l )*inv_nr1*at(ipol,1) + &
DBLE( j )*inv_nr2*at(ipol,2) + &
DBLE( k )*inv_nr3*at(ipol,3)
END DO
posi(ipol) = dble( l )*inv_nr1*at(ipol,1) + &
dble( j )*inv_nr2*at(ipol,2) + &
dble( k )*inv_nr3*at(ipol,3)
ENDDO
!
! find the distance of real-space grid's point ir w.r.t
! closer periodic image of atom ia
!
posi(:) = posi(:) - tau(:,ia)
CALL cryst_to_cart( 1, posi, bg, -1 )
posi(:) = posi(:) - ANINT( posi(:) )
posi(:) = posi(:) - anint( posi(:) )
CALL cryst_to_cart( 1, posi, at, 1 )
!
posi(:) = posi(:) * alat
@ -152,17 +152,17 @@ SUBROUTINE PAW_make_ae_charge(rho)
! do interpolation
rho%of_r(ir,is)= rho%of_r(ir,is) + ylm_posi(1,lm) &
* splint(g(i%t)%r(:) , rho_lm(:,lm,is), &
wsp_lm(:,lm,is), SQRT(distsq) )
wsp_lm(:,lm,is), sqrt(distsq) )
ENDDO
ENDDO
END DO rsp_point
ENDDO rsp_point
!
DEALLOCATE(rho_lm, ylm_posi, wsp_lm)
!
ENDIF ifpaw
ENDDO atoms
END SUBROUTINE PAW_make_ae_charge
END MODULE paw_postproc

164
PP/pawplot.f90
View File

@ -30,11 +30,11 @@ SUBROUTINE PAW_make_ae_charge_ ( rho, flag, nx, r, rhopaw )
USE gvect, ONLY : nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx
USE cell_base, ONLY : at, bg, alat
!
TYPE(scf_type), INTENT(IN) :: rho ! only rho%bec is actually needed
INTEGER, INTENT (IN) :: flag ! -1=core, 0 =valence, 1=both
INTEGER, INTENT (IN) :: nx ! number of points in space
REAL (dp), INTENT(IN) :: r(3,nx) ! points in space (alat units)
REAL (dp), INTENT(OUT) :: rhopaw(nx,nspin) ! PAW charge
TYPE(scf_type), INTENT(in) :: rho ! only rho%bec is actually needed
INTEGER, INTENT (in) :: flag ! -1=core, 0 =valence, 1=both
INTEGER, INTENT (in) :: nx ! number of points in space
REAL (dp), INTENT(in) :: r(3,nx) ! points in space (alat units)
REAL (dp), INTENT(out) :: rhopaw(nx,nspin) ! PAW charge
!
TYPE(paw_info) :: i ! minimal info on atoms
INTEGER :: ip ! counter on x,y,z
@ -86,16 +86,16 @@ SUBROUTINE PAW_make_ae_charge_ ( rho, flag, nx, r, rhopaw )
ENDDO
ELSE
rho_lm(:,:,is) = 0.0_dp
END IF
ENDIF
!
! add core charge (divide by Y_00=1/sqrt(4pi) to get l=0 component)
!
!
IF ( abs(flag) == 1 ) THEN
DO ir = 1, i%m
rho_lm(ir,1,is) = rho_lm(ir,1,is) + &
sqrt( fpi ) * upf(i%t)%paw%ae_rho_atc(ir) / nspin
ENDDO
END IF
ENDIF
ENDDO
! deallocate asap
@ -126,7 +126,7 @@ SUBROUTINE PAW_make_ae_charge_ ( rho, flag, nx, r, rhopaw )
!
posi(:) = posi(:) - tau(:,ia)
CALL cryst_to_cart( 1, posi, bg, -1 )
posi(:) = posi(:) - ANINT( posi(:) )
posi(:) = posi(:) - anint( posi(:) )
CALL cryst_to_cart( 1, posi, at, 1 )
!
posi(:) = posi(:) * alat
@ -135,7 +135,7 @@ SUBROUTINE PAW_make_ae_charge_ ( rho, flag, nx, r, rhopaw )
! don't consider points too far from the atom
! (criterion not valid in principle if core charge is present)
!
IF ( abs(flag) == 1 .AND. &
IF ( abs(flag) == 1 .and. &
distsq > g(i%t)%r2(upf(i%t)%kkbeta) ) CYCLE rsp_point
!
! generate the atomic charge on point posi(:), which means
@ -149,18 +149,18 @@ SUBROUTINE PAW_make_ae_charge_ ( rho, flag, nx, r, rhopaw )
! do interpolation
rhopaw(ir,is)= rhopaw(ir,is) + ylm_posi(1,lm) &
* splint(g(i%t)%r(:) , rho_lm(:,lm,is), &
wsp_lm(:,lm,is), SQRT(distsq) )
wsp_lm(:,lm,is), sqrt(distsq) )
ENDDO
ENDDO
END DO rsp_point
ENDDO rsp_point
!
DEALLOCATE(rho_lm, ylm_posi, wsp_lm)
!
ENDIF ifpaw
ENDDO atoms
END SUBROUTINE PAW_make_ae_charge_
END MODULE paw_postproc_
!
!-----------------------------------------------------------------------
@ -190,7 +190,7 @@ PROGRAM PAWplot
REAL(dp) :: e1(3), e2(3), e3(3), x0(3)
REAL(dp), ALLOCATABLE :: rhoplot(:), rhopaw(:,:), r(:,:)
COMPLEX(dp), ALLOCATABLE :: rhog(:)
LOGICAL, external :: matches
LOGICAL, EXTERNAL :: matches
LOGICAL :: onedim, twodim, tredim
!
NAMELIST / inputpp / outdir, prefix, spin_component, &
@ -209,8 +209,8 @@ PROGRAM PAWplot
!
prefix = 'pwscf'
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
filplot = 'pawcharge.dat'
IF ( trim( outdir ) == ' ' ) outdir = './'
filplot = 'pawcharge.dat'
plot = 'valence'
spin_component = 0
e1(:) = 0.d0
@ -230,10 +230,10 @@ PROGRAM PAWplot
!
tmp_dir = trimcheck ( outdir )
!
END IF
call mp_bcast (ios, ionode_id)
ENDIF
CALL mp_bcast (ios, ionode_id)
IF ( ios /= 0) &
CALL errore ('postproc', 'reading inputpp namelist', ABS(ios))
CALL errore ('postproc', 'reading inputpp namelist', abs(ios))
!
! ... Broadcast variables
!
@ -270,31 +270,31 @@ PROGRAM PAWplot
rhog (:) = rho%of_g(:,current_spin)
ENDIF
ENDIF
!
tredim = ( e3(1)**2 + e3(2)**2 + e3(3)**2 > 1d-6 )
twodim = ( e2(1)**2 + e2(2)**2 + e2(3)**2 > 1d-6 ) .AND. .NOT. tredim
onedim = ( e1(1)**2 + e1(2)**2 + e1(3)**2 > 1d-6 ) .AND. .NOT. twodim
!
if ( onedim ) then
tredim = ( e3(1)**2 + e3(2)**2 + e3(3)**2 > 1d-6 )
twodim = ( e2(1)**2 + e2(2)**2 + e2(3)**2 > 1d-6 ) .and. .not. tredim
onedim = ( e1(1)**2 + e1(2)**2 + e1(3)**2 > 1d-6 ) .and. .not. twodim
!
IF ( onedim ) THEN
!
! One-dimensional plot
!
if (nx <= 0 ) call errore ('chdens', 'wrong nx', 1)
IF (nx <= 0 ) CALL errore ('chdens', 'wrong nx', 1)
ALLOCATE ( rhoplot(nx) )
IF ( okpaw ) THEN
WRITE (stdout, '(5x,"Reconstructing all-electron charge (PAW)")')
ALLOCATE ( rhopaw(nx,nspin), r(3,nx) )
DO is = 1, nx
r(:, is) = x0 (:) + (is-1) * e1(:) / (nx-1)
END DO
ENDDO
!
IF ( matches ('core',plot) .AND. matches ('valence',plot) ) THEN
IF ( matches ('core',plot) .and. matches ('valence',plot) ) THEN
flag = 1
ELSE IF ( matches ('core',plot) ) THEN
ELSEIF ( matches ('core',plot) ) THEN
flag =-1
ELSE
flag = 0
END IF
flag = 0
ENDIF
CALL PAW_make_ae_charge_ (rho, flag, nx, r, rhopaw )
!
IF (spin_component == 0 .and. nspin ==2 ) THEN
@ -302,105 +302,105 @@ PROGRAM PAWplot
ELSE
IF (nspin == 2) current_spin = spin_component
rhoplot(:) = rhopaw(:,current_spin)
END IF
ENDIF
DEALLOCATE ( r, rhopaw )
ELSE
rhoplot(:) = 0.0_dp
END IF
ENDIF
!
call plot_1d_ (nx, x0, e1, rhog, rhoplot, flag, filplot )
CALL plot_1d_ (nx, x0, e1, rhog, rhoplot, flag, filplot )
!
DEALLOCATE ( rhoplot )
!
else if ( twodim ) then
if ( abs(e1(1)*e2(1) + e1(2)*e2(2) + e1(3)*e2(3)) > 1d-6) &
call errore ('pawplot', 'e1 and e2 are not orthogonal', 1)
if ( nx <= 0 .OR. ny <= 0 ) call errore ('chdens', 'wrong nx or ny', 1)
else if (tredim) then
if ( nx <= 0 .OR. ny <= 0 .OR. nz <=0 ) &
call errore ('chdens', 'wrong nx or ny or nz', 1)
END IF
ELSEIF ( twodim ) THEN
IF ( abs(e1(1)*e2(1) + e1(2)*e2(2) + e1(3)*e2(3)) > 1d-6) &
CALL errore ('pawplot', 'e1 and e2 are not orthogonal', 1)
IF ( nx <= 0 .or. ny <= 0 ) CALL errore ('chdens', 'wrong nx or ny', 1)
ELSEIF (tredim) THEN
IF ( nx <= 0 .or. ny <= 0 .or. nz <=0 ) &
CALL errore ('chdens', 'wrong nx or ny or nz', 1)
ENDIF
!
DEALLOCATE (rhog)
end PROGRAM PAWPLOT
END PROGRAM PAWPLOT
!
!-----------------------------------------------------------------------
subroutine plot_1d_ (nx, x0, e, rhog, rhoplot, flag, filplot )
SUBROUTINE plot_1d_ (nx, x0, e, rhog, rhoplot, flag, filplot )
!-----------------------------------------------------------------------
!
USE kinds, only : DP
use constants, only: pi
USE io_global, only : stdout, ionode
USE kinds, ONLY : DP
USE constants, ONLY: pi
USE io_global, ONLY : stdout, ionode
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
USE gvect, ONLY : g, gstart, ngm
USE control_flags, ONLY : gamma_only
implicit none
integer, intent(in) :: nx, flag
IMPLICIT NONE
INTEGER, INTENT(in) :: nx, flag
! number of points along the line
! flag=-1: do not add smooth term
real(DP), intent(in) :: e (3), x0 (3)
real(DP), INTENT(in) :: e (3), x0 (3)
! vector defining the line
! origin of the line
complex(DP), intent(in) :: rhog (ngm)
COMPLEX(DP), INTENT(in) :: rhog (ngm)
! rho in G space
character(LEN=*), intent(in) :: filplot
real(DP), intent(inout) :: rhoplot(nx)
CHARACTER(len=*), INTENT(in) :: filplot
real(DP), INTENT(inout) :: rhoplot(nx)
!
integer :: i, ig, ounit
INTEGER :: i, ig, ounit
real(DP) :: rhosum(nx), rhomin, rhomax, x(3), deltax, arg
!
do i = 1, nx
DO i = 1, nx
x(:) = x0 (:) + (i-1) * e (:) / (nx-1)
!
! for each point we compute the charge from the Fourier components
!
rhosum(i) = 0.0_dp
do ig = gstart, ngm
DO ig = gstart, ngm
!
! NB: G are in 2pi/alat units, r are in alat units
!
arg = 2.0_dp*pi* ( x(1)*g(1,ig) + x(2)*g(2,ig) + x(3)*g(3,ig) )
rhosum(i) = rhosum(i) + DBLE ( rhog (ig) ) * cos (arg) - &
AIMAG ( rhog (ig) ) * sin (arg)
enddo
if ( gamma_only ) rhosum(i) = 2.0_dp * rhosum(i)
if ( gstart == 2 ) rhosum(i) = rhosum(i) + DBLE( rhog (1) )
rhosum(i) = rhosum(i) + dble ( rhog (ig) ) * cos (arg) - &
aimag ( rhog (ig) ) * sin (arg)
ENDDO
IF ( gamma_only ) rhosum(i) = 2.0_dp * rhosum(i)
IF ( gstart == 2 ) rhosum(i) = rhosum(i) + dble( rhog (1) )
!
enddo
call mp_sum( rhosum, intra_pool_comm )
ENDDO
CALL mp_sum( rhosum, intra_pool_comm )
!
IF ( flag /= -1) rhoplot (:) = rhoplot(:) + rhosum(:)
!
! Here we check the value of the resulting charge
!
rhomin = MINVAL ( rhoplot(:) )
rhomax = MAXVAL ( rhoplot(:) )
write(stdout, '(5x,"Min, Max charge: ",2f12.6)') rhomin, rhomax
rhomin = minval ( rhoplot(:) )
rhomax = maxval ( rhoplot(:) )
WRITE(stdout, '(5x,"Min, Max charge: ",2f12.6)') rhomin, rhomax
!
! we print the charge on output
!
if (ionode) then
if (filplot /= ' ') then
IF (ionode) THEN
IF (filplot /= ' ') THEN
ounit = 1
open (unit=ounit, file=filplot, form='formatted', status='unknown')
OPEN (unit=ounit, file=filplot, form='formatted', status='unknown')
WRITE( stdout, '(/5x,"Writing data to be plotted to file ",a)') &
TRIM(filplot)
else
trim(filplot)
ELSE
ounit = 6
endif
ENDIF
!
deltax = sqrt(e(1)**2+e(2)**2+e(3)**2) / (nx - 1)
do i = 1, nx
write (ounit, '(2f20.10)') deltax*DBLE(i-1), rhoplot(i)
enddo
if (ounit == 1) CLOSE (unit = ounit, status='keep')
end if
return
DO i = 1, nx
WRITE (ounit, '(2f20.10)') deltax*dble(i-1), rhoplot(i)
ENDDO
IF (ounit == 1) CLOSE (unit = ounit, status='keep')
ENDIF
end subroutine plot_1d_
RETURN
END SUBROUTINE plot_1d_

114
PP/plan_avg.f90
View File

@ -49,8 +49,8 @@ PROGRAM plan_avg
!
prefix = 'pwscf'
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
filplot = 'tmp.pp'
IF ( trim( outdir ) == ' ' ) outdir = './'
filplot = 'tmp.pp'
!
ios = 0
!
@ -61,10 +61,10 @@ PROGRAM plan_avg
READ (5, inputpp, iostat = ios)
tmp_dir = trimcheck (outdir)
!
END IF
ENDIF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios /= 0 ) CALL errore ('plan_avg', 'reading inputpp namelist', ABS(ios))
IF ( ios /= 0 ) CALL errore ('plan_avg', 'reading inputpp namelist', abs(ios))
!
! ... Broadcast variables
!
@ -81,8 +81,8 @@ PROGRAM plan_avg
!
CALL openfil_pp ( )
!
ALLOCATE (averag( nat, nbnd, nkstot))
ALLOCATE (plan(nr3, nbnd, nkstot))
ALLOCATE (averag( nat, nbnd, nkstot))
ALLOCATE (plan(nr3, nbnd, nkstot))
!
CALL do_plan_avg (averag, plan, ninter)
!
@ -90,7 +90,7 @@ PROGRAM plan_avg
!
OPEN (UNIT = iunplot, FILE = filplot, FORM = 'formatted', &
STATUS = 'unknown', err = 100, IOSTAT = ios)
100 CALL errore ('plan_avg', 'opening file '//TRIM(filplot), abs (ios) )
100 CALL errore ('plan_avg', 'opening file '//trim(filplot), abs (ios) )
WRITE (iunplot, '(a)') title
WRITE (iunplot, '(8i8)') nrx1, nrx2, nrx3, nr1, nr2, nr3, nat, ntyp
WRITE (iunplot, '(i6,6f12.8)') ibrav, celldm
@ -98,7 +98,7 @@ PROGRAM plan_avg
WRITE ( iunplot, * ) at(:,1)
WRITE ( iunplot, * ) at(:,2)
WRITE ( iunplot, * ) at(:,3)
END IF
ENDIF
WRITE (iunplot, '(3f20.10,i6)') gcutm, dual, ecutwfc, 9
WRITE (iunplot, '(i4,3x,a2,3x,f5.2)') &
(nt, atm (nt), zv (nt), nt=1, ntyp)
@ -125,7 +125,7 @@ PROGRAM plan_avg
CONTAINS
!
subroutine do_plan_avg (averag, plan, ninter)
SUBROUTINE do_plan_avg (averag, plan, ninter)
!
! This routine computes the planar average on the xy plane
! for the charge density of each state of the system.
@ -153,8 +153,8 @@ subroutine do_plan_avg (averag, plan, ninter)
USE io_files, ONLY: iunwfc, nwordwfc
USE becmod, ONLY: bec_type, becp, calbec, allocate_bec_type, deallocate_bec_type
implicit none
integer :: ninter
IMPLICIT NONE
INTEGER :: ninter
! output: the number of planes
real(DP) :: averag (nat, nbnd, nkstot), plan (nr3, nbnd, nkstot)
! output: the average charge on ea
@ -162,7 +162,7 @@ subroutine do_plan_avg (averag, plan, ninter)
!
! Local variables
!
integer :: ik, ibnd, iin, na, ir, ij, ind, i1 (nat), ntau (nat + 1)
INTEGER :: ik, ibnd, iin, na, ir, ij, ind, i1 (nat), ntau (nat + 1)
! counter on k points
! counter on bands
! counter on planes
@ -178,7 +178,7 @@ subroutine do_plan_avg (averag, plan, ninter)
! auxiliary for coordinates
! length in a.u. of the cell along z
if ( celldm(3) == 0.d0 ) celldm(3) = celldm(1)
IF ( celldm(3) == 0.d0 ) celldm(3) = celldm(1)
zdim = alat * celldm (3)
sp_min = 2.d0 / alat
!
@ -190,95 +190,95 @@ subroutine do_plan_avg (averag, plan, ninter)
z1 (ninter) = tau (3, 1)
avg (ninter) = tau (3, 1)
ntau (ninter) = 1
do na = 2, nat
do iin = 1, ninter
if (abs (mod (z1(iin)-tau(3,na), celldm(3)) ) .lt. sp_min) then
DO na = 2, nat
DO iin = 1, ninter
IF (abs (mod (z1(iin)-tau(3,na), celldm(3)) ) < sp_min) THEN
avg (iin) = avg (iin) + tau (3, na)
ntau (iin) = ntau (iin) + 1
goto 100
endif
enddo
GOTO 100
ENDIF
ENDDO
ninter = ninter + 1
z1 (ninter) = tau (3, na)
avg (ninter) = tau (3, na)
ntau (ninter) = 1
100 continue
enddo
100 CONTINUE
ENDDO
!
! for each plane compute the average position of the central plane
! and first point in the fft mesh
!
do iin = 1, ninter
DO iin = 1, ninter
z1 (iin) = mod (avg (iin), celldm (3) ) / ntau (iin)
ind = (z1 (iin) / celldm (3) ) * nr3 + 1
if (ind.le.0) ind = ind+nr3
IF (ind<=0) ind = ind+nr3
i1 (iin) = ind
enddo
ENDDO
!
! order the points
!
do iin = 1, ninter
DO iin = 1, ninter
ntau (iin) = i1 (iin)
do ik = iin + 1, ninter
if (i1 (ik) .lt.ntau (iin) ) then
DO ik = iin + 1, ninter
IF (i1 (ik) <ntau (iin) ) THEN
ij = ntau (iin)
ntau (iin) = i1 (ik)
i1 (ik) = ij
endif
enddo
enddo
ENDIF
ENDDO
ENDDO
ntau (ninter + 1) = ntau (1) + nr3
!
! and compute the point associated to each plane
!
do iin = 1, ninter
DO iin = 1, ninter
i1 (iin) = (ntau (iin) + ntau (iin + 1) ) / 2
enddo
ENDDO
!
! for each state compute the planar average
!
averag(:,:,:) = 0.d0
plan(:,:,:) = 0.d0
call allocate_bec_type ( nkb, nbnd, becp )
CALL allocate_bec_type ( nkb, nbnd, becp )
! CALL init_us_1 ( )
do ik = 1, nks
if (lsda) current_spin = isk (ik)
call gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
call davcio (evc, nwordwfc, iunwfc, ik, - 1)
call init_us_2 (npw, igk, xk (1, ik), vkb)
DO ik = 1, nks
IF (lsda) current_spin = isk (ik)
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
CALL init_us_2 (npw, igk, xk (1, ik), vkb)
call calbec ( npw, vkb, evc, becp)
CALL calbec ( npw, vkb, evc, becp)
do ibnd = 1, nbnd
call local_dos1d (ik, ibnd, plan (1, ibnd, ik) )
DO ibnd = 1, nbnd
CALL local_dos1d (ik, ibnd, plan (1, ibnd, ik) )
!
! compute the integrals of the charge
!
do ir = 1, i1 (1) - 1
DO ir = 1, i1 (1) - 1
averag (1, ibnd, ik) = averag (1, ibnd, ik) + plan (ir, ibnd, ik)
enddo
do ir = i1 (ninter), nr3
ENDDO
DO ir = i1 (ninter), nr3
averag (1, ibnd, ik) = averag (1, ibnd, ik) + plan (ir, ibnd, ik)
enddo
ENDDO
averag (1, ibnd, ik) = averag (1, ibnd, ik) * zdim / nr3
sum = averag (1, ibnd, ik)
do iin = 2, ninter
do ir = i1 (iin - 1), i1 (iin) - 1
DO iin = 2, ninter
DO ir = i1 (iin - 1), i1 (iin) - 1
averag(iin,ibnd,ik) = averag(iin,ibnd,ik) + plan(ir,ibnd,ik)
enddo
ENDDO
averag (iin, ibnd, ik) = averag (iin, ibnd, ik) * zdim / nr3
sum = sum + averag (iin, ibnd, ik)
enddo
enddo
enddo
call deallocate_bec_type (becp)
ENDDO
ENDDO
ENDDO
CALL deallocate_bec_type (becp)
#ifdef __PARA
call poolrecover (plan, nr3 * nbnd, nkstot, nks)
call poolrecover (averag, nat * nbnd, nkstot, nks)
call poolrecover (xk, 3, nkstot, nks)
CALL poolrecover (plan, nr3 * nbnd, nkstot, nks)
CALL poolrecover (averag, nat * nbnd, nkstot, nks)
CALL poolrecover (xk, 3, nkstot, nks)
#endif
return
end subroutine do_plan_avg
RETURN
END SUBROUTINE do_plan_avg
END PROGRAM plan_avg

28
PP/plot_whole_cell.f90
View File

@ -5,31 +5,31 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
subroutine plot_whole_cell (alat, at, nat, tau, atm, ityp, &
SUBROUTINE plot_whole_cell (alat, at, nat, tau, atm, ityp, &
nr1, nr2, nr3, nrx1, nrx2, nrx3, rho, output_format, ounit)
USE kinds, only : DP
implicit none
integer :: nat, ityp (nat), output_format, ounit
integer :: nrx1, nrx2, nrx3, nr1, nr2, nr3
character(len=3) :: atm(*)
USE kinds, ONLY : DP
IMPLICIT NONE
INTEGER :: nat, ityp (nat), output_format, ounit
INTEGER :: nrx1, nrx2, nrx3, nr1, nr2, nr3
CHARACTER(len=3) :: atm(*)
real(DP) :: alat, tau (3, nat), at (3, 3), rho(2, nrx1,nrx2,nrx3)
if ( output_format .eq. 3 ) then
IF ( output_format == 3 ) THEN
!
! XCRYSDEN FORMAT
!
call xsf_struct (alat, at, nat, tau, atm, ityp, ounit)
call xsf_fast_datagrid_3d &
CALL xsf_struct (alat, at, nat, tau, atm, ityp, ounit)
CALL xsf_fast_datagrid_3d &
(rho, nr1, nr2, nr3, nrx1, nrx2, nrx3, at, alat, ounit)
elseif ( output_format .eq. 4 ) then
ELSEIF ( output_format == 4 ) THEN
!
! gOpenMol format
!
! not yet implemented
! add code here ...
else
call errore('plot_whole_cell', 'wrong output_format', 1)
endif
end subroutine plot_whole_cell
ELSE
CALL errore('plot_whole_cell', 'wrong output_format', 1)
ENDIF
END SUBROUTINE plot_whole_cell

698
PP/plotband.f90
View File

@ -5,181 +5,181 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
program plotband
PROGRAM plotband
implicit none
integer, parameter :: stdout=6
real, allocatable :: e(:,:), k(:,:), e_in(:), kx(:)
IMPLICIT NONE
INTEGER, PARAMETER :: stdout=6
real, ALLOCATABLE :: e(:,:), k(:,:), e_in(:), kx(:)
real :: k1(3), k2(3), ps
real, allocatable :: e_rap(:,:), k_rap(:,:)
integer, allocatable :: nbnd_rapk(:), rap(:,:)
integer, allocatable :: npoints(:)
integer :: nks = 0, nbnd = 0, ios, nlines, n,i,j,ni,nf,nl
integer :: nks_rap = 0, nbnd_rap = 0
logical, allocatable :: high_symmetry(:), is_in_range(:), is_in_range_rap(:)
character(len=256) :: filename, filename1
namelist /plot/ nks, nbnd
namelist /plot_rap/ nks_rap, nbnd_rap
integer :: n_interp
real, allocatable :: k_interp(:), e_interp(:), coef_interp(:,:)
real, ALLOCATABLE :: e_rap(:,:), k_rap(:,:)
INTEGER, ALLOCATABLE :: nbnd_rapk(:), rap(:,:)
INTEGER, ALLOCATABLE :: npoints(:)
INTEGER :: nks = 0, nbnd = 0, ios, nlines, n,i,j,ni,nf,nl
INTEGER :: nks_rap = 0, nbnd_rap = 0
LOGICAL, ALLOCATABLE :: high_symmetry(:), is_in_range(:), is_in_range_rap(:)
CHARACTER(len=256) :: filename, filename1
NAMELIST /plot/ nks, nbnd
NAMELIST /plot_rap/ nks_rap, nbnd_rap
INTEGER :: n_interp
real, ALLOCATABLE :: k_interp(:), e_interp(:), coef_interp(:,:)
real :: emin = 1.e10, emax =-1.e10, etic, eref, deltaE, Ef
integer, parameter :: max_lines=99
INTEGER, PARAMETER :: max_lines=99
real :: mine
integer :: point(max_lines+1), nrap(max_lines)
integer :: ilines, irap, ibnd, ipoint, jnow
INTEGER :: point(max_lines+1), nrap(max_lines)
INTEGER :: ilines, irap, ibnd, ipoint, jnow
real, parameter :: cm=28.453, xdim=15.0*cm, ydim=10.0*cm, &
real, PARAMETER :: cm=28.453, xdim=15.0*cm, ydim=10.0*cm, &
x0=2.0*cm, y0=2.0*cm, eps=1.e-4
logical :: exist_rap
logical, allocatable :: todo(:,:)
LOGICAL :: exist_rap
LOGICAL, ALLOCATABLE :: todo(:,:)
call get_file ( filename )
open(unit=1,file=filename,form='formatted')
read (1, plot, iostat=ios)
CALL get_file ( filename )
OPEN(unit=1,file=filename,form='formatted')
READ (1, plot, iostat=ios)
!
if (nks <= 0 .or. nbnd <= 0 .or. ios /= 0) then
stop 'Error reading file header'
else
print '("Reading ",i4," bands at ",i4," k-points")', nbnd, nks
end if
IF (nks <= 0 .or. nbnd <= 0 .or. ios /= 0) THEN
STOP 'Error reading file header'
ELSE
PRINT '("Reading ",i4," bands at ",i4," k-points")', nbnd, nks
ENDIF
filename1=TRIM(filename)//".rap"
filename1=trim(filename)//".rap"
exist_rap=.true.
open(unit=21,file=filename1,form='formatted',status='old',err=100,iostat=ios)
OPEN(unit=21,file=filename1,form='formatted',status='old',err=100,iostat=ios)
100 if (ios .ne. 0) then
100 IF (ios /= 0) THEN
exist_rap=.false.
endif
if (exist_rap) then
read (21, plot_rap, iostat=ios)
if (nks_rap.ne.nks.or.nbnd_rap.ne.nbnd.or.ios.ne.0) then
write(6,'("file with representations not compatible with bands")')
exist_rap=.FALSE.
endif
endif
ENDIF
IF (exist_rap) THEN
READ (21, plot_rap, iostat=ios)
IF (nks_rap/=nks.or.nbnd_rap/=nbnd.or.ios/=0) THEN
WRITE(6,'("file with representations not compatible with bands")')
exist_rap=.false.
ENDIF
ENDIF
!
allocate (e(nbnd,nks))
allocate (k(3,nks), e_in(nks), kx(nks), npoints(nks), high_symmetry(nks))
allocate (is_in_range(nbnd))
ALLOCATE (e(nbnd,nks))
ALLOCATE (k(3,nks), e_in(nks), kx(nks), npoints(nks), high_symmetry(nks))
ALLOCATE (is_in_range(nbnd))
if (exist_rap) then
allocate(nbnd_rapk(nks))
allocate(e_rap(nbnd,nks))
allocate(rap(nbnd,nks))
allocate(k_rap(3,nks))
allocate(todo(nbnd,2))
allocate (is_in_range_rap(nbnd))
end if
IF (exist_rap) THEN
ALLOCATE(nbnd_rapk(nks))
ALLOCATE(e_rap(nbnd,nks))
ALLOCATE(rap(nbnd,nks))
ALLOCATE(k_rap(3,nks))
ALLOCATE(todo(nbnd,2))
ALLOCATE (is_in_range_rap(nbnd))
ENDIF
high_symmetry=.FALSE.
high_symmetry=.false.
do n=1,nks
read(1,*,end=20,err=20) ( k(i,n), i=1,3 )
read(1,*,end=20,err=20) (e(i,n),i=1,nbnd)
if (n==1) then
DO n=1,nks
READ(1,*,end=20,err=20) ( k(i,n), i=1,3 )
READ(1,*,end=20,err=20) (e(i,n),i=1,nbnd)
IF (n==1) THEN
kx(n) = 0.d0
else
ELSE
kx(n) = kx(n-1) + sqrt ( (k(1,n)-k(1,n-1))**2 + &
(k(2,n)-k(2,n-1))**2 + &
(k(3,n)-k(3,n-1))**2 )
end if
ENDIF
if (exist_rap) then
read(21,*,end=20,err=20) (k_rap(i,n),i=1,3), high_symmetry(n)
read(21,*,end=20,err=20) (rap(i,n),i=1,nbnd)
if (abs(k(1,n)-k_rap(1,n))+abs(k(2,n)-k_rap(2,n))+ &
abs(k(3,n)-k_rap(3,n)) > eps ) then
write(stdout,'("Incompatible k points in rap file")')
deallocate(nbnd_rapk)
deallocate(e_rap)
deallocate(rap)
deallocate(k_rap)
deallocate(todo)
deallocate(is_in_range_rap)
close(unit=21)
IF (exist_rap) THEN
READ(21,*,end=20,err=20) (k_rap(i,n),i=1,3), high_symmetry(n)
READ(21,*,end=20,err=20) (rap(i,n),i=1,nbnd)
IF (abs(k(1,n)-k_rap(1,n))+abs(k(2,n)-k_rap(2,n))+ &
abs(k(3,n)-k_rap(3,n)) > eps ) THEN
WRITE(stdout,'("Incompatible k points in rap file")')
DEALLOCATE(nbnd_rapk)
DEALLOCATE(e_rap)
DEALLOCATE(rap)
DEALLOCATE(k_rap)
DEALLOCATE(todo)
DEALLOCATE(is_in_range_rap)
CLOSE(unit=21)
exist_rap=.false.
end if
end if
end do
close(unit=1)
if (exist_rap) close(unit=21)
ENDIF
ENDIF
ENDDO
CLOSE(unit=1)
IF (exist_rap) CLOSE(unit=21)
do n=1,nks
do i=1,nbnd
DO n=1,nks
DO i=1,nbnd
emin = min(emin, e(i,n))
emax = max(emax, e(i,n))
end do
end do
print '("Range:",2f10.4,"eV Emin, Emax > ",$)', emin, emax
read(5,*) emin, emax
ENDDO
ENDDO
PRINT '("Range:",2f10.4,"eV Emin, Emax > ",$)', emin, emax
READ(5,*) emin, emax
is_in_range = .false.
do i=1,nbnd
DO i=1,nbnd
is_in_range(i) = any (e(i,1:nks) >= emin .and. e(i,1:nks) <= emax)
end do
ENDDO
do n=1,nks
if (n==1 .or. n==nks) then
DO n=1,nks
IF (n==1 .or. n==nks) THEN
high_symmetry(n) = .true.
else
do i=1,3
ELSE
DO i=1,3
k1(i) = k(i,n)-k(i,n-1)
k2(i) = k(i,n+1)-k(i,n)
end do
ENDDO
ps = ( k1(1)*k2(1) + k1(2)*k2(2) + k1(3)*k2(3) ) / &
sqrt( k1(1)*k1(1) + k1(2)*k1(2) + k1(3)*k1(3) ) / &
sqrt( k2(1)*k2(1) + k2(2)*k2(2) + k2(3)*k2(3) )
high_symmetry(n) = high_symmetry(n).OR.(abs(ps-1.0) .gt.1.0d-4)
high_symmetry(n) = high_symmetry(n).or.(abs(ps-1.0) >1.0d-4)
!
! The gamma point is a high symmetry point
! The gamma point is a high symmetry point
!
if (k(1,n)**2+k(2,n)**2+k(3,n)**2 < 1.0d-9) high_symmetry(n)=.true.
end if
IF (k(1,n)**2+k(2,n)**2+k(3,n)**2 < 1.0d-9) high_symmetry(n)=.true.
ENDIF
if (high_symmetry(n)) then
if (n==1) then
IF (high_symmetry(n)) THEN
IF (n==1) THEN
nlines=0
npoints(1)=1
else if (n==nks) then
ELSEIF (n==nks) THEN
npoints(nlines+1) = npoints(nlines+1)+1
nlines=nlines+1
else
ELSE
npoints(nlines+1) = npoints(nlines+1)+1
nlines=nlines+1
npoints(nlines+1) = 1
end if
ENDIF
point(nlines+1)=n
WRITE( stdout,'("high-symmetry point: ",3f7.4)') (k(i,n),i=1,3)
else
ELSE
npoints(nlines+1) = npoints(nlines+1)+1
end if
end do
ENDIF
ENDDO
!
print '("output file (xmgr) > ",$)'
read(5,'(a)', end=25, err=25) filename
if (filename == ' ' ) then
print '("skipping ...")'
go to 25
end if
if (.not.exist_rap) then
open (unit=2,file=filename,form='formatted',status='unknown',&
iostat=ios)
PRINT '("output file (xmgr) > ",$)'
READ(5,'(a)', end=25, err=25) filename
IF (filename == ' ' ) THEN
PRINT '("skipping ...")'
GOTO 25
ENDIF
IF (.not.exist_rap) THEN
OPEN (unit=2,file=filename,form='formatted',status='unknown',&
iostat=ios)
! draw bands
do i=1,nbnd
if (is_in_range(i)) then
if ( mod(i,2) /= 0) then
write (2,'(2f10.4)') (kx(n), e(i,n),n=1,nks)
else
write (2,'(2f10.4)') (kx(n), e(i,n),n=nks,1,-1)
end if
end if
end do
close (unit = 2)
else
DO i=1,nbnd
IF (is_in_range(i)) THEN
IF ( mod(i,2) /= 0) THEN
WRITE (2,'(2f10.4)') (kx(n), e(i,n),n=1,nks)
ELSE
WRITE (2,'(2f10.4)') (kx(n), e(i,n),n=nks,1,-1)
ENDIF
ENDIF
ENDDO
CLOSE (unit = 2)
ELSE
!
! In this case we write a diffent file for each line and for each
! representation. Each file contains the bands of that representation.
@ -188,214 +188,214 @@ program plotband
!
! First determine for each line how many representations are there
!
do ilines=1,nlines
DO ilines=1,nlines
nrap(ilines)=0
do ipoint=1,npoints(ilines)-2
DO ipoint=1,npoints(ilines)-2
n=point(ilines) + ipoint
do ibnd=1,nbnd
DO ibnd=1,nbnd
nrap(ilines)=max(nrap(ilines),rap(ibnd,n))
end do
end do
write(6,*) 'lines nrap',ilines, nrap(ilines)
end do
ENDDO
ENDDO
WRITE(6,*) 'lines nrap',ilines, nrap(ilines)
ENDDO
!
! Then, for each line and for each representation along that line
!
do ilines=1,nlines
if (nrap(ilines)==0) then
DO ilines=1,nlines
IF (nrap(ilines)==0) THEN
!
! Along this line the symmetry decomposition has not been done.
! Along this line the symmetry decomposition has not been done.
! Plot all the bands as in the standard case
!
if (ilines<10) then
write(filename1,'(a,".",i1)') TRIM(filename), ilines
else
write(filename1,'(a,".",i2)') TRIM(filename), ilines
endif
open (unit=2,file=filename1,form='formatted',status='unknown',&
iostat=ios)
IF (ilines<10) THEN
WRITE(filename1,'(a,".",i1)') trim(filename), ilines
ELSE
WRITE(filename1,'(a,".",i2)') trim(filename), ilines
ENDIF
OPEN (unit=2,file=filename1,form='formatted',status='unknown',&
iostat=ios)
! draw bands
do i=1,nbnd
if (is_in_range(i)) then
if ( mod(i,2) /= 0) then
write (2,'(2f10.4)') (kx(n), e(i,n),n=point(ilines),&
DO i=1,nbnd
IF (is_in_range(i)) THEN
IF ( mod(i,2) /= 0) THEN
WRITE (2,'(2f10.4)') (kx(n), e(i,n),n=point(ilines),&
point(ilines+1))
else
write (2,'(2f10.4)') (kx(n), e(i,n),n=point(ilines+1), &
ELSE
WRITE (2,'(2f10.4)') (kx(n), e(i,n),n=point(ilines+1), &
point(ilines),-1 )
end if
end if
end do
close (unit = 2)
endif
ENDIF
ENDIF
ENDDO
CLOSE (unit = 2)
ENDIF
todo=.true.
do irap=1, nrap(ilines)
DO irap=1, nrap(ilines)
!
! open a file
!
if (ilines>99.or.irap>12) then
write(6,'("too many lines or rap")')
stop
endif
if (ilines < 10) then
if (irap < 10 ) then
write(filename1,'(a,".",i1,".",i1)') TRIM(filename),ilines,irap
else
write(filename1,'(a,".",i1,".",i2)') TRIM(filename),ilines,irap
endif
else
if (irap < 10 ) then
write(filename1,'(a,".",i2,".",i1)') TRIM(filename),ilines,irap
else
write(filename1,'(a,".",i2,".",i2)') TRIM(filename),ilines,irap
endif
endif
open (unit=2,file=filename1,form='formatted',status='unknown',&
IF (ilines>99.or.irap>12) THEN
WRITE(6,'("too many lines or rap")')
STOP
ENDIF
IF (ilines < 10) THEN
IF (irap < 10 ) THEN
WRITE(filename1,'(a,".",i1,".",i1)') trim(filename),ilines,irap
ELSE
WRITE(filename1,'(a,".",i1,".",i2)') trim(filename),ilines,irap
ENDIF
ELSE
IF (irap < 10 ) THEN
WRITE(filename1,'(a,".",i2,".",i1)') trim(filename),ilines,irap
ELSE
WRITE(filename1,'(a,".",i2,".",i2)') trim(filename),ilines,irap
ENDIF
ENDIF
OPEN (unit=2,file=filename1,form='formatted',status='unknown',&
iostat=ios)
! For each k point along this line selects only the bands which belong
! to the irap representation
nbnd_rapk=100000
do n=point(ilines)+1, point(ilines+1)-1
DO n=point(ilines)+1, point(ilines+1)-1
nbnd_rapk(n)=0
do i=1,nbnd
if (rap(i,n)==irap) then
DO i=1,nbnd
IF (rap(i,n)==irap) THEN
nbnd_rapk(n) = nbnd_rapk(n) + 1
e_rap(nbnd_rapk(n),n)=e(i,n)
endif
enddo
enddo
ENDIF
ENDDO
ENDDO
!
! on the two high symmetry points the representation is different. So for each
! band choose the closest eigenvalue available.
!
do i=1,nbnd_rapk(point(ilines)+1)
DO i=1,nbnd_rapk(point(ilines)+1)
mine=1.e8
do j=1,nbnd
if (abs(e_rap(i,point(ilines)+1)-e(j,point(ilines)))<mine &
.and. todo(j,1)) then
DO j=1,nbnd
IF (abs(e_rap(i,point(ilines)+1)-e(j,point(ilines)))<mine &
.and. todo(j,1)) THEN
e_rap(i,point(ilines))=e(j,point(ilines))
mine=abs( e_rap(i,point(ilines)+1)-e(j,point(ilines)))
jnow=j
end if
end do
ENDIF
ENDDO
todo(jnow,1)=.false.
end do
do i=1,nbnd_rapk(point(ilines+1)-1)
ENDDO
DO i=1,nbnd_rapk(point(ilines+1)-1)
mine=1.e8
do j=1,nbnd
if (abs(e_rap(i,point(ilines+1)-1)- &
e(j,point(ilines+1)))<mine .and. todo(j,2)) then
DO j=1,nbnd
IF (abs(e_rap(i,point(ilines+1)-1)- &
e(j,point(ilines+1)))<mine .and. todo(j,2)) THEN
e_rap(i,point(ilines+1))=e(j,point(ilines+1))
mine=abs(e_rap(i,point(ilines+1)-1)-e(j,point(ilines+1)) )
jnow=j
end if
end do
ENDIF
ENDDO
todo(jnow,2)=.false.
end do
ENDDO
is_in_range_rap=.false.
do i=1,MINVAL(nbnd_rapk)
DO i=1,minval(nbnd_rapk)
is_in_range_rap(i) = any (e_rap(i,point(ilines):point(ilines+1))&
>= emin .and. e(i,point(ilines):point(ilines+1)) <= emax)
enddo
do i=1,MINVAL(nbnd_rapk)
if (is_in_range_rap(i)) then
if ( mod(i,2) /= 0) then
write (2,'(2f10.4)') (kx(n), e_rap(i,n), &
ENDDO
DO i=1,minval(nbnd_rapk)
IF (is_in_range_rap(i)) THEN
IF ( mod(i,2) /= 0) THEN
WRITE (2,'(2f10.4)') (kx(n), e_rap(i,n), &
n=point(ilines),point(ilines+1))
else
write (2,'(2f10.4)') (kx(n), e_rap(i,n), &
ELSE
WRITE (2,'(2f10.4)') (kx(n), e_rap(i,n), &
n=point(ilines+1),point(ilines),-1)
end if
end if
end do
if (MINVAL(nbnd_rapk)==0) THEN
close (unit = 2,status='delete')
else
close (unit = 2)
endif
end do
end do
endif
print '("bands in xmgr format written to file ",a)', filename
ENDIF
ENDIF
ENDDO
IF (minval(nbnd_rapk)==0) THEN
CLOSE (unit = 2,status='delete')
ELSE
CLOSE (unit = 2)
ENDIF
ENDDO
ENDDO
ENDIF
PRINT '("bands in xmgr format written to file ",a)', filename
!
25 continue
if (exist_rap) then
deallocate(nbnd_rapk)
deallocate(e_rap)
deallocate(rap)
deallocate(k_rap)
deallocate(todo)
endif
print '("output file (ps) > ",$)'
read(5,'(a)',end=30,err=30) filename
if (filename == ' ' ) then
print '("stopping ...")'
go to 30
end if
open (unit=1,file=filename,form='formatted',status='unknown',&
iostat=ios)
print '("Efermi > ",$)'
read(5,*) Ef
print '("deltaE, reference E (for tics) ",$)'
read(5,*) deltaE, eref
25 CONTINUE
IF (exist_rap) THEN
DEALLOCATE(nbnd_rapk)
DEALLOCATE(e_rap)
DEALLOCATE(rap)
DEALLOCATE(k_rap)
DEALLOCATE(todo)
ENDIF
PRINT '("output file (ps) > ",$)'
READ(5,'(a)',end=30,err=30) filename
IF (filename == ' ' ) THEN
PRINT '("stopping ...")'
GOTO 30
ENDIF
OPEN (unit=1,file=filename,form='formatted',status='unknown',&
iostat=ios)
PRINT '("Efermi > ",$)'
READ(5,*) Ef
PRINT '("deltaE, reference E (for tics) ",$)'
READ(5,*) deltaE, eref
!
write (1,'(a)') '%! PS-Adobe-1.0'
write (1,*) '/localdict 100 dict def'
write (1,*) 'localdict begin'
write (1,*) '% delete next line for insertion in a LaTeX file'
write (1,*) ' 0 0 moveto'
write (1,*) 'gsave'
write (1,*) '/nm {newpath moveto} def'
write (1,*) '/riga {newpath moveto lineto stroke} def'
write (1,*) '/banda {3 1 roll moveto {lineto} repeat stroke} def'
write (1,*) '/dot {newpath 1 0 360 arc fill} def'
write (1,*) '/Times-Roman findfont 12 scalefont setfont'
write (1,*) 'currentpoint translate'
write (1,*) '% Landscape: uncomment next line'
write (1,*) ' 90 rotate 0 21 neg 28.451 mul translate 1.5 1.5 scale'
write (1,*) '% Landscape: comment next line'
write (1,*) '% 1.2 1.2 scale'
write (1,'(2(f8.3,1x)," translate")') x0, y0
write (1,*) '0 setgray 0.5 setlinewidth'
WRITE (1,'(a)') '%! PS-Adobe-1.0'
WRITE (1,*) '/localdict 100 dict def'
WRITE (1,*) 'localdict begin'
WRITE (1,*) '% delete next line for insertion in a LaTeX file'
WRITE (1,*) ' 0 0 moveto'
WRITE (1,*) 'gsave'
WRITE (1,*) '/nm {newpath moveto} def'
WRITE (1,*) '/riga {newpath moveto lineto stroke} def'
WRITE (1,*) '/banda {3 1 roll moveto {lineto} repeat stroke} def'
WRITE (1,*) '/dot {newpath 1 0 360 arc fill} def'
WRITE (1,*) '/Times-Roman findfont 12 scalefont setfont'
WRITE (1,*) 'currentpoint translate'
WRITE (1,*) '% Landscape: uncomment next line'
WRITE (1,*) ' 90 rotate 0 21 neg 28.451 mul translate 1.5 1.5 scale'
WRITE (1,*) '% Landscape: comment next line'
WRITE (1,*) '% 1.2 1.2 scale'
WRITE (1,'(2(f8.3,1x)," translate")') x0, y0
WRITE (1,*) '0 setgray 0.5 setlinewidth'
! draw tics on axis
ni=nint((eref-emin)/deltaE)+1
nf=nint((emax-eref)/deltaE)+1
do i=-ni,nf
DO i=-ni,nf
etic=eref+i*deltaE
if (etic >= emin .and. etic <= emax) then
write (1,'(2(f8.3,1x)," moveto -5 0 rlineto stroke")') &
IF (etic >= emin .and. etic <= emax) THEN
WRITE (1,'(2(f8.3,1x)," moveto -5 0 rlineto stroke")') &
0.0,(etic-emin)*ydim/(emax-emin)
write (1,'(2(f8.3,1x)," moveto (",f5.1,") show")') &
WRITE (1,'(2(f8.3,1x)," moveto (",f5.1,") show")') &
-30.,(etic-emin)*ydim/(emax-emin), etic-eref
end if
end do
ENDIF
ENDDO
! draw the Fermi Energy
if (Ef > emin .and. Ef < emax) then
write (1,'("[2 4] 0 setdash newpath ",2(f8.3,1x), " moveto ")') &
IF (Ef > emin .and. Ef < emax) THEN
WRITE (1,'("[2 4] 0 setdash newpath ",2(f8.3,1x), " moveto ")') &
0.0, (Ef-emin)/(emax-emin)*ydim
write (1,'(2(f8.3,1x)," lineto stroke [] 0 setdash")') &
WRITE (1,'(2(f8.3,1x)," lineto stroke [] 0 setdash")') &
xdim, (Ef-emin)/(emax-emin)*ydim
end if
ENDIF
! draw axis and set clipping region
write (1,*) '1 setlinewidth'
write (1,'(8(f8.3,1x))') 0.0,0.0,0.0,ydim,xdim,ydim,xdim,0.0
write (1,*) 'newpath moveto lineto lineto lineto closepath clip stroke'
write (1,*) '0.5 setlinewidth'
WRITE (1,*) '1 setlinewidth'
WRITE (1,'(8(f8.3,1x))') 0.0,0.0,0.0,ydim,xdim,ydim,xdim,0.0
WRITE (1,*) 'newpath moveto lineto lineto lineto closepath clip stroke'
WRITE (1,*) '0.5 setlinewidth'
! draw high-symmetry lines
do n=1,nks
if (high_symmetry(n)) then
write (1,'(4(f8.3,1x)," riga")') &
DO n=1,nks
IF (high_symmetry(n)) THEN
WRITE (1,'(4(f8.3,1x)," riga")') &
kx(n)*xdim/kx(nks), 0.0, kx(n)*xdim/kx(nks), ydim
end if
do i=1,nbnd
if (is_in_range(i)) write (1,'(2(f8.3,1x)," dot")' ) &
ENDIF
DO i=1,nbnd
IF (is_in_range(i)) WRITE (1,'(2(f8.3,1x)," dot")' ) &
kx(n)*xdim/kx(nks), (e(i,n)-emin)*ydim/(emax-emin)
end do
end do
ENDDO
ENDDO
! draw bands
allocate (k_interp(4*nks), e_interp(4*nks), coef_interp(nks,4))
do i=1,nbnd
if (is_in_range(i)) then
ALLOCATE (k_interp(4*nks), e_interp(4*nks), coef_interp(nks,4))
DO i=1,nbnd
IF (is_in_range(i)) THEN
! No interpolation:
! write (1,'(9(f8.3,1x))') ( kx(n)*xdim/kx(nks), &
! (e(i,n)-emin)*ydim/(emax-emin),n=nks,1,-1)
@ -404,48 +404,48 @@ program plotband
!
ni=1
nf=1
do nl=1,nlines
DO nl=1,nlines
ni=nf
nf=nf + npoints(nl)-1
n_interp= 2*(nf-ni)+1
do n=1,n_interp
DO n=1,n_interp
k_interp(n)=kx(ni)+(n-1)*(kx(nf)-kx(ni))/(n_interp-1)
end do
do n=ni,nf
ENDDO
DO n=ni,nf
e_in(n-ni+1)=e(i,n)
end do
call spline_interpol ( kx(ni), e_in, nf-ni+1, &
ENDDO
CALL spline_interpol ( kx(ni), e_in, nf-ni+1, &
k_interp, e_interp, n_interp )
write (1,'(9(f8.3,1x))') ( k_interp(n)*xdim/kx(nks), &
WRITE (1,'(9(f8.3,1x))') ( k_interp(n)*xdim/kx(nks), &
(e_interp(n)-emin)*ydim/(emax-emin),n=n_interp,1,-1)
write (1,'(i4," banda")' ) n_interp-1
end do
end if
end do
WRITE (1,'(i4," banda")' ) n_interp-1
ENDDO
ENDIF
ENDDO
write (1,*) 'grestore'
write (1,*) '% delete next lines for insertion in a tex file'
write (1,'(a)') '%%Page'
write (1,*) 'showpage'
close (unit=1)
print '("bands in PostScript format written to file ",a)', filename
30 continue
WRITE (1,*) 'grestore'
WRITE (1,*) '% delete next lines for insertion in a tex file'
WRITE (1,'(a)') '%%Page'
WRITE (1,*) 'showpage'
CLOSE (unit=1)
PRINT '("bands in PostScript format written to file ",a)', filename
30 CONTINUE
stop
20 print '("Error reading k-point # ",i4)', n
stop
STOP
20 PRINT '("Error reading k-point # ",i4)', n
STOP
contains
CONTAINS
subroutine spline_interpol (xin, yin, nin, xout, yout, nout)
SUBROUTINE spline_interpol (xin, yin, nin, xout, yout, nout)
! xin and xout should be in increasing order, with
! xout(1) <= xin(1), xout(nout) <= xin(nin)
implicit none
integer, intent(in) :: nin, nout
real, intent(in) :: xin(nin), yin(nin), xout(nout)
real, intent(out) :: yout(nout)
IMPLICIT NONE
INTEGER, INTENT(in) :: nin, nout
real, INTENT(in) :: xin(nin), yin(nin), xout(nout)
real, INTENT(out) :: yout(nout)
! work space (automatically allocated)
real :: d2y(nin)
real :: dy1, dyn
@ -453,82 +453,82 @@ subroutine spline_interpol (xin, yin, nin, xout, yout, nout)
dy1 = (yin(2)-yin(1))/(xin(2)-xin(1))
dyn = 0.0
call spline( xin, yin, nin, dy1, dyn, d2y)
call splint( nin, xin, yin, d2y, nout, xout, yout)
CALL spline( xin, yin, nin, dy1, dyn, d2y)
CALL splint( nin, xin, yin, d2y, nout, xout, yout)
return
end subroutine spline_interpol
RETURN
END SUBROUTINE spline_interpol
subroutine spline(x, y, n, yp1, ypn, d2y)
SUBROUTINE spline(x, y, n, yp1, ypn, d2y)
implicit none
integer, intent(in) :: n
real, intent(in) :: x(n), y(n), yp1, ypn
real, intent(out):: d2y(n)
IMPLICIT NONE
INTEGER, INTENT(in) :: n
real, INTENT(in) :: x(n), y(n), yp1, ypn
real, INTENT(out):: d2y(n)
! work space (automatically allocated)
real :: work(n)
integer :: i, k
INTEGER :: i, k
real :: sig, p, qn, un
d2y(1)=-0.5
work(1)=(3.0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
do i=2,n-1
DO i=2,n-1
sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
p=sig*d2y(i-1)+2.0
d2y(i)=(sig-1.0)/p
work(i)=(6.0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*work(i-1))/p
end do
ENDDO
qn=0.5
un=(3.0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
d2y(n)=(un-qn*work(n-1))/(qn*d2y(n-1)+1.0)
do k=n-1,1,-1
DO k=n-1,1,-1
d2y(k)=d2y(k)*d2y(k+1)+work(k)
end do
ENDDO
return
end subroutine spline
RETURN
END SUBROUTINE spline
subroutine splint (nspline, xspline, yspline, d2y, nfit, xfit, yfit)
SUBROUTINE splint (nspline, xspline, yspline, d2y, nfit, xfit, yfit)
implicit none
IMPLICIT NONE
! input
integer, intent(in) :: nspline, nfit
real, intent(in) :: xspline(nspline), yspline(nspline), xfit(nfit), &
INTEGER, INTENT(in) :: nspline, nfit
real, INTENT(in) :: xspline(nspline), yspline(nspline), xfit(nfit), &
d2y(nspline)
real, intent(out) :: yfit(nfit)
integer :: klo, khi, i
real :: a, b, h
real, INTENT(out) :: yfit(nfit)
INTEGER :: klo, khi, i
real :: a, b, h
klo=1
do i=1,nfit
do khi=klo+1, nspline
if(xspline(khi) >= xfit(i)) then
if(xspline(khi-1) <= xfit(i)) then
DO i=1,nfit
DO khi=klo+1, nspline
IF(xspline(khi) >= xfit(i)) THEN
IF(xspline(khi-1) <= xfit(i)) THEN
klo = khi-1
else
if (klo == 1 .and. khi-1 == 1) then
ELSE
IF (klo == 1 .and. khi-1 == 1) THEN
! the case xfit(i) < xspline(1) should not happen
! but since it may be due to a numerical artifact
! we just continue
print *, ' SPLINT WARNING: xfit(i) < xspline(1)', &
xfit(i), xspline(1)
else
stop ' SPLINT ERROR: xfit not properly ordered'
end if
end if
h= xspline(khi) - xspline(klo)
PRINT *, ' SPLINT WARNING: xfit(i) < xspline(1)', &
xfit(i), xspline(1)
ELSE
STOP ' SPLINT ERROR: xfit not properly ordered'
ENDIF
ENDIF
h= xspline(khi) - xspline(klo)
a= (xspline(khi)-xfit(i))/h
b= (xfit(i)-xspline(klo))/h
yfit(i) = a*yspline(klo) + b*yspline(khi) &
+ ( (a**3-a)*d2y(klo) + (b**3-b)*d2y(khi) )*h*h/6.0
go to 10
end if
end do
GOTO 10
ENDIF
ENDDO
! the case xfit(i) > xspline(nspline) should also not happen
! but again it may be due to a numerical artifact
@ -536,21 +536,21 @@ subroutine splint (nspline, xspline, yspline, d2y, nfit, xfit, yfit)
! (and in the case xfit(i) < xspline(1) above as well) but
! I am too lazy to write one - PG
print *, ' SPLINT WARNING: xfit(i) > xspline(nspline)', &
xfit(i), xspline(nspline)
PRINT *, ' SPLINT WARNING: xfit(i) > xspline(nspline)', &
xfit(i), xspline(nspline)
khi = klo+1
h= xspline(khi) - xspline(klo)
h= xspline(khi) - xspline(klo)
a= (xspline(khi)-xfit(i))/h
b= (xfit(i)-xspline(klo))/h
yfit(i) = a*yspline(klo) + b*yspline(khi) &
+ ( (a**3-a)*d2y(klo) + (b**3-b)*d2y(khi) )*h*h/6.0
!
10 continue
end do
return
end subroutine splint
10 CONTINUE
ENDDO
end program plotband
RETURN
END SUBROUTINE splint
END PROGRAM plotband

100
PP/plotproj.f90
View File

@ -7,10 +7,10 @@
!
PROGRAM plotproj
!
! This small program is used to select the band eigenvalues whose
! This small program is used to select the band eigenvalues whose
! wavefunctions projected on atomic wavefunctions have projections larger
! than a given threshold. It requires two input files. The first is a
! file with the band eigenvalues, written in the output of pw.x.
! file with the band eigenvalues, written in the output of pw.x.
! The input file with the bands has the following format:
! nbnd, nks ! number of bands, number of k points
! --- blank line
@ -49,7 +49,7 @@ PROGRAM plotproj
INTEGER :: nks = 0, nbnd = 0, ios, n, i, ibnd, na, idum, nat, &
natomwfc, nwfc, ntyp, ncri, icri
LOGICAL, ALLOCATABLE :: toplot(:,:)
CHARACTER(LEN=256) :: filename, filename1
CHARACTER(len=256) :: filename, filename1
REAL(DP) :: psum, threshold
REAL(DP), ALLOCATABLE :: proj(:,:,:)
INTEGER, ALLOCATABLE :: first_atomic_wfc(:), last_atomic_wfc(:)
@ -57,42 +57,42 @@ PROGRAM plotproj
CALL get_file ( filename )
OPEN(UNIT=1,FILE=filename,FORM='formatted',status='old',iostat=ios)
IF (ios.NE.0) STOP 'Error opening band file '
IF (ios/=0) STOP 'Error opening band file '
READ(1,*, err=20, iostat=ios) nbnd, nks
IF (nks <= 0 .OR. nbnd <= 0 ) THEN
IF (nks <= 0 .or. nbnd <= 0 ) THEN
STOP 'Error reading file header'
ELSE
PRINT '("Reading ",i4," bands at ",i4," k-points")', nbnd, nks
END IF
ENDIF
ALLOCATE (e(nbnd,nks))
ALLOCATE (k(3,nks))
ALLOCATE (kx(nks))
ALLOCATE (toplot(nbnd,nks))
DO n=1,nks
READ(1, *, ERR=20, IOSTAT=ios)
READ(1, '(13x,3f7.4)', ERR=20, IOSTAT=ios) (k(i,n), i=1,3)
READ(1, *, ERR=20, IOSTAT=ios)
READ(1, '(2x,8f9.4)', END=20, ERR=20) (e(i,n),i=1,nbnd)
IF (n==1) THEN
kx(n) = SQRT (k(1,1)**2 + k(2,1)**2 + k(3,1)**2)
kx(n) = sqrt (k(1,1)**2 + k(2,1)**2 + k(3,1)**2)
ELSE
kx(n) = kx(n-1) + SQRT ( (k(1,n)-k(1,n-1))**2 + &
kx(n) = kx(n-1) + sqrt ( (k(1,n)-k(1,n-1))**2 + &
(k(2,n)-k(2,n-1))**2 + &
(k(3,n)-k(3,n-1))**2 )
END IF
END DO
20 IF (ios.ne.0) STOP "problem reading files"
ENDIF
ENDDO
20 IF (ios/=0) STOP "problem reading files"
CLOSE(UNIT=1)
CALL get_file ( filename1 )
OPEN(UNIT=1, FILE=filename1, FORM='formatted', STATUS='old', IOSTAT=ios)
IF (ios.ne.0) STOP 'Error opening projection file '
READ(1, *, ERR=20, IOSTAT=ios)
IF (ios/=0) STOP 'Error opening projection file '
READ(1, *, ERR=20, IOSTAT=ios)
READ (1, '(8i8)', ERR=20, IOSTAT=ios) idum, idum, idum, idum, idum, &
idum, nat, ntyp
DO i=1,2+nat+ntyp
@ -100,29 +100,29 @@ PROGRAM plotproj
ENDDO
READ (1, '(3i8)',ERR=20, IOSTAT=ios) natomwfc, nks, nbnd
READ (1, *, ERR=20, IOSTAT=ios)
ALLOCATE( proj(natomwfc,nbnd,nks) )
DO nwfc = 1, natomwfc
READ(1, *, ERR=20, IOSTAT=ios)
READ(1, *, ERR=20, IOSTAT=ios)
DO n=1,nks
DO ibnd=1,nbnd
READ(1, '(2i8,f20.10)', ERR=20, IOSTAT=ios) idum,idum,proj(nwfc,ibnd,n)
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
CLOSE(1)
PRINT '("output file > ",$)'
READ(5,'(a)', END=25, ERR=25) filename
IF (filename == ' ' ) THEN
PRINT '("skipping ...")'
GO TO 25
END IF
OPEN (UNIT=2,FILE=filename,FORM='formatted',STATUS='unknown',IOSTAT=ios)
IF (ios.ne.0) STOP "Error opening output file "
GOTO 25
ENDIF
OPEN (UNIT=2,FILE=filename,FORM='formatted',STATUS='unknown',IOSTAT=ios)
IF (ios/=0) STOP "Error opening output file "
READ(5, *, ERR=20, IOSTAT=ios) threshold
READ(5, *, ERR=20, IOSTAT=ios) ncri
IF (ncri<1) STOP '("no orbital given ...")'
@ -131,34 +131,34 @@ PROGRAM plotproj
DO icri=1,ncri
READ(5, *, ERR=20, IOSTAT=ios) first_atomic_wfc(icri), &
last_atomic_wfc(icri)
IF (first_atomic_wfc(icri)>natomwfc.OR.last_atomic_wfc(icri)>natomwfc .OR. &
first_atomic_wfc(icri)<1 .OR. &
last_atomic_wfc(icri)<first_atomic_wfc(icri) ) THEN
IF (first_atomic_wfc(icri)>natomwfc.or.last_atomic_wfc(icri)>natomwfc .or. &
first_atomic_wfc(icri)<1 .or. &
last_atomic_wfc(icri)<first_atomic_wfc(icri) ) THEN
PRINT '("Problem with ...",i5)', icri
GO TO 25
END IF
END DO
toplot=.FALSE.
GOTO 25
ENDIF
ENDDO
toplot=.false.
DO i=1,nbnd
DO n=1,nks
psum=0.d0
DO icri=1,ncri
DO nwfc=first_atomic_wfc(icri),last_atomic_wfc(icri)
psum=psum+ABS(proj(nwfc,i,n))
END DO
END DO
toplot(i,n)=toplot(i,n).OR.(psum > threshold)
END DO
END DO
psum=psum+abs(proj(nwfc,i,n))
ENDDO
ENDDO
toplot(i,n)=toplot(i,n).or.(psum > threshold)
ENDDO
ENDDO
DO i=1,nbnd
DO n=1,nks
IF (toplot(i,n)) WRITE (2,'(2f10.4)') kx(n), e(i,n)
END DO
END DO
ENDDO
ENDDO
CLOSE (UNIT = 2)
25 CONTINUE
END PROGRAM plotproj

950
PP/plotrho.f90
View File

File diff suppressed because it is too large Load Diff

316
PP/poormanwannier.f90
View File

@ -4,107 +4,107 @@
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#define ONE (1.D0,0.D0)
#define ZERO (0.D0,0.D0)
!
!-----------------------------------------------------------------------
#define ONE (1.D0,0.D0)
#define ZERO (0.D0,0.D0)
!
!-----------------------------------------------------------------------
PROGRAM pmw
!-----------------------------------------------------------------------
!
! projects wavefunctions onto atomic wavefunctions,
!
! input: namelist "&inputpp", with variables
! prefix prefix of input files saved by program pwscf
! outdir temporary directory where files resides
!
USE kinds, ONLY : DP
!-----------------------------------------------------------------------
!
! projects wavefunctions onto atomic wavefunctions,
!
! input: namelist "&inputpp", with variables
! prefix prefix of input files saved by program pwscf
! outdir temporary directory where files resides
!
USE kinds, ONLY : DP
USE io_global, ONLY : stdout, ionode, ionode_id
USE io_files, ONLY : prefix, tmp_dir, trimcheck
USE mp, ONLY : mp_bcast
USE mp_global, ONLY : mp_startup
USE environment,ONLY : environment_start
!
IMPLICIT NONE
IMPLICIT NONE
CHARACTER(len=256) :: outdir
INTEGER :: ios
INTEGER :: first_band, last_band
NAMELIST / inputpp / outdir, prefix, first_band, last_band
!
!
! initialise environment
!
#ifdef __PARA
CALL mp_startup ( )
#endif
CALL environment_start ( 'PMW' )
!
! set default values for variables in namelist
!
prefix = 'pwscf'
!
! set default values for variables in namelist
!
prefix = 'pwscf'
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
IF ( trim( outdir ) == ' ' ) outdir = './'
first_band=-1
last_band=-1
!
!
ios = 0
!
IF ( ionode ) THEN
!
READ (5, inputpp, iostat = ios)
!
tmp_dir = trimcheck (outdir)
!
END IF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios/=0 ) CALL errore ('pmwannier', 'reading inputpp namelist', ABS(ios))
!
! ... Broadcast variables
!
CALL mp_bcast( tmp_dir, ionode_id )
CALL mp_bcast( prefix, ionode_id )
CALL mp_bcast( first_band, ionode_id )
CALL mp_bcast( last_band, ionode_id )
!
! Now allocate space for pwscf variables, read and check them.
!
IF ( ionode ) THEN
!
READ (5, inputpp, iostat = ios)
!
tmp_dir = trimcheck (outdir)
!
ENDIF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios/=0 ) CALL errore ('pmwannier', 'reading inputpp namelist', abs(ios))
!
! ... Broadcast variables
!
CALL mp_bcast( tmp_dir, ionode_id )
CALL mp_bcast( prefix, ionode_id )
CALL mp_bcast( first_band, ionode_id )
CALL mp_bcast( last_band, ionode_id )
!
! Now allocate space for pwscf variables, read and check them.
!
CALL read_file ( )
!
CALL openfil_pp ( )
CALL openfil_pp ( )
!
CALL projection( first_band, last_band)
!
CALL stop_pp
!
!
CALL stop_pp
!
END PROGRAM pmw
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
SUBROUTINE projection (first_band, last_band)
!-----------------------------------------------------------------------
!
USE io_global, ONLY : stdout
USE uspp_param, ONLY : upf
!-----------------------------------------------------------------------
!
USE io_global, ONLY : stdout
USE uspp_param, ONLY : upf
USE ions_base, ONLY : nat, ityp
USE basis, ONLY : natomwfc
USE cell_base
USE constants, ONLY: rytoev
USE gvect
USE klist
USE constants, ONLY: rytoev
USE gvect
USE klist
USE ldaU, ONLY : swfcatom, lda_plus_u, &
Hubbard_lmax, Hubbard_l, Hubbard_alpha, Hubbard_U
USE lsda_mod
USE lsda_mod
USE symm_base, ONLY: nsym, irt, d1, d2, d3
USE wvfct
USE wvfct
USE control_flags, ONLY: gamma_only
USE uspp, ONLY: nkb, vkb
USE becmod, ONLY: bec_type, becp, calbec, allocate_bec_type, deallocate_bec_type
USE io_files, ONLY: nd_nmbr, prefix, tmp_dir, nwordwfc, iunwfc, &
iunsat, nwordatwfc, diropn
USE wavefunctions_module, ONLY: evc
USE wavefunctions_module, ONLY: evc
IMPLICIT NONE
IMPLICIT NONE
!
! I/O variables
! I/O variables
!
INTEGER :: first_band, last_band
!
@ -112,14 +112,14 @@ SUBROUTINE projection (first_band, last_band)
!
INTEGER :: ik, na, nt, n, m, l, nwfc, lmax_wfc, &
ldim1, ldim2, lwork, i, j, info, counter, counter_ldau
LOGICAL :: exst
LOGICAL :: exst
COMPLEX(DP), ALLOCATABLE :: proj (:,:,:)
COMPLEX(DP), ALLOCATABLE :: wfcatom (:,:)
!
COMPLEX(DP), ALLOCATABLE :: proj0(:,:)
! Some workspace for k-point calculation ...
REAL (DP), ALLOCATABLE :: rproj0(:,:)
! ... or for gamma-point.
COMPLEX(DP), ALLOCATABLE :: wfcatom (:,:)
!
COMPLEX(DP), ALLOCATABLE :: proj0(:,:)
! Some workspace for k-point calculation ...
REAL (DP), ALLOCATABLE :: rproj0(:,:)
! ... or for gamma-point.
COMPLEX(DP), ALLOCATABLE :: pp(:,:), u_m(:,:), w_m(:,:), work(:)
! the overlap matrix pp
! left unitary matrix in the SVD of sp_m
@ -129,24 +129,24 @@ SUBROUTINE projection (first_band, last_band)
! the eigenvalues of pp
! workspace for ZGESVD
REAL (DP) :: capel
!
WRITE( stdout, '(/5x,"Calling projection .... ")')
IF ( gamma_only ) WRITE( stdout, '(5x,"gamma-point specific algorithms are used")')
!
!
WRITE( stdout, '(/5x,"Calling projection .... ")')
IF ( gamma_only ) WRITE( stdout, '(5x,"gamma-point specific algorithms are used")')
!
nwordatwfc = 2 * npwx * natomwfc
CALL diropn( iunsat, 'satwfc', nwordatwfc, exst )
!
ALLOCATE(proj (natomwfc, nbnd, nkstot) )
ALLOCATE(wfcatom (npwx, natomwfc) )
ALLOCATE(proj (natomwfc, nbnd, nkstot) )
ALLOCATE(wfcatom (npwx, natomwfc) )
! Allocate the array containing <beta|wfcatom>
call allocate_bec_type ( nkb, natomwfc, becp)
CALL allocate_bec_type ( nkb, natomwfc, becp)
IF (first_band == -1) first_band = 1
IF (last_band == -1) last_band = nbnd
IF (first_band > last_band ) CALL errore ('pmw',' first_band > last_band',1)
IF (first_band < 0 ) CALL errore ('pmw',' first_band < 0 ', 1)
IF (last_band > nbnd ) CALL errore ('pmw',' last_band > nbnd ', 1)
counter = 0
counter_ldaU = 0
@ -155,10 +155,10 @@ SUBROUTINE projection (first_band, last_band)
DO n = 1, upf(nt)%nwfc
IF (upf(nt)%oc (n) >= 0.d0) THEN
l = upf(nt)%lchi (n)
IF ( (Hubbard_U(nt).NE.0.d0 .OR. Hubbard_alpha(nt).NE.0.d0) .AND. &
l.EQ.Hubbard_l(nt) )THEN
IF ( (Hubbard_U(nt)/=0.d0 .or. Hubbard_alpha(nt)/=0.d0) .and. &
l==Hubbard_l(nt) )THEN
counter_ldaU = counter_ldaU + 2 * l + 1
END IF
ENDIF
counter = counter + 2 * l + 1
ENDIF
ENDDO
@ -167,74 +167,74 @@ SUBROUTINE projection (first_band, last_band)
WRITE( stdout, *) " NBND = ", nbnd
WRITE( stdout, *) " NATOMWFC =", natomwfc
WRITE( stdout, *) " NKSTOT =", nkstot
ldim1 = counter_ldaU
ldim2 = last_band + 1 - first_band
WRITE( stdout, *) ldim1, ldim2
IF (ldim1 > ldim2 ) CALL errore( 'projection','too few bands',ldim1-ldim2)
lwork = 5 * MAX(ldim1,ldim2)
lwork = 5 * max(ldim1,ldim2)
ALLOCATE (pp(ldim1,ldim2), u_m(ldim1,ldim1), w_m(ldim2,ldim2), &
work(lwork), ew(ldim1), rwork(lwork))
proj = 0.d0
!
! initialize D_Sl for l=1, l=2 and l=3, for l=0 D_S0 is 1
!
CALL d_matrix (d1, d2, d3)
proj = 0.d0
!
! initialize D_Sl for l=1, l=2 and l=3, for l=0 D_S0 is 1
!
CALL d_matrix (d1, d2, d3)
WRITE (stdout,*) " Hubbard_lmax = ", Hubbard_lmax, lda_plus_u
nwfc=0
lmax_wfc = 0
DO na = 1, nat
nt = ityp (na)
nwfc=0
lmax_wfc = 0
DO na = 1, nat
nt = ityp (na)
DO n = 1, upf(nt)%nwfc
IF (upf(nt)%oc (n) >= 0.d0) THEN
l = upf(nt)%lchi (n)
lmax_wfc = MAX (lmax_wfc, l )
DO m = 1, 2 * l + 1
nwfc=nwfc+1
IF (upf(nt)%oc (n) >= 0.d0) THEN
l = upf(nt)%lchi (n)
lmax_wfc = max (lmax_wfc, l )
DO m = 1, 2 * l + 1
nwfc=nwfc+1
WRITE(stdout,*) " ATOMIC WFC #", nwfc,":", na,n,l,m
ENDDO
ENDIF
ENDDO
ENDDO
IF (lmax_wfc > 3) CALL errore ('projection', 'l > 3 not yet implemented', 1)
ENDDO
ENDIF
ENDDO
ENDDO
IF (lmax_wfc > 3) CALL errore ('projection', 'l > 3 not yet implemented', 1)
IF (nwfc /= natomwfc) CALL errore ('projection', 'wrong # of atomic wfcs?', 1)
!
! loop on k points
!
CALL init_us_1
CALL init_at_1
!
DO ik = 1, nks
!
! loop on k points
!
CALL init_us_1
CALL init_at_1
!
DO ik = 1, nks
WRITE ( stdout, * ) "KPOINT =", ik
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
CALL atomic_wfc (ik, wfcatom)
CALL init_us_2 (npw, igk, xk (1, ik), vkb)
CALL calbec ( npw, vkb, wfcatom, becp )
CALL s_psi (npwx, npw, natomwfc, wfcatom, swfcatom)
!
! wfcatom = |phi_i> , swfcatom = \hat S |phi_i>
!
! make the projection <psi_i| \hat S | phi_j>
!
IF ( gamma_only ) THEN
ALLOCATE(rproj0(natomwfc,nbnd) )
CALL calbec ( npw, swfcatom, evc, rproj0 )
proj(:,:,ik) = CMPLX(rproj0(:,:),0.d0,kind=DP)
DEALLOCATE (rproj0)
ELSE
ALLOCATE(proj0(natomwfc,nbnd) )
CALL calbec ( npw, swfcatom, evc, proj0 )
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
CALL atomic_wfc (ik, wfcatom)
CALL init_us_2 (npw, igk, xk (1, ik), vkb)
CALL calbec ( npw, vkb, wfcatom, becp )
CALL s_psi (npwx, npw, natomwfc, wfcatom, swfcatom)
!
! wfcatom = |phi_i> , swfcatom = \hat S |phi_i>
!
! make the projection <psi_i| \hat S | phi_j>
!
IF ( gamma_only ) THEN
ALLOCATE(rproj0(natomwfc,nbnd) )
CALL calbec ( npw, swfcatom, evc, rproj0 )
proj(:,:,ik) = cmplx(rproj0(:,:),0.d0,kind=DP)
DEALLOCATE (rproj0)
ELSE
ALLOCATE(proj0(natomwfc,nbnd) )
CALL calbec ( npw, swfcatom, evc, proj0 )
proj(:,:,ik) = proj0(:,:)
DEALLOCATE (proj0)
END IF
DEALLOCATE (proj0)
ENDIF
counter = 0
counter_ldaU = 0
@ -243,26 +243,26 @@ SUBROUTINE projection (first_band, last_band)
DO n = 1, upf(nt)%nwfc
IF (upf(nt)%oc (n) >= 0.d0) THEN
l = upf(nt)%lchi (n)
IF ( (Hubbard_U(nt).NE.0.d0.OR.Hubbard_alpha(nt).NE.0.d0) .AND. &
l.EQ.Hubbard_l(nt) )THEN
IF ( (Hubbard_U(nt)/=0.d0.or.Hubbard_alpha(nt)/=0.d0) .and. &
l==Hubbard_l(nt) )THEN
pp(counter_ldaU+1:counter_ldaU+2*l+1, 1:ldim2) = &
proj(counter+1:counter+2*l+1,first_band:last_band,ik)
counter_ldaU = counter_ldaU + 2 * l + 1
END IF
ENDIF
counter = counter + 2 * l + 1
ENDIF
ENDDO
ENDDO
IF (counter_ldaU .NE. ldim1) CALL errore ('projection','wrong counter',1)
IF (counter_ldaU /= ldim1) CALL errore ('projection','wrong counter',1)
CALL ZGESVD( 'A', 'A', ldim1, ldim2, pp, ldim1, ew, u_m, ldim1, &
w_m, ldim2, work, lwork, rwork, info )
CALL errore ('projection','Singular Value Deconposition failed', ABS(info))
CALL errore ('projection','Singular Value Deconposition failed', abs(info))
DO i = 1, ldim1
WRITE ( stdout, * ) ew(i)
WRITE ( stdout, '(8(2f5.2,2x))') u_m(:,i)
WRITE ( stdout, '(8(2f5.2,2x))') w_m(i,:)
END DO
ENDDO
!
! ... use sp_m to store u_m * w_m
!
@ -275,10 +275,10 @@ SUBROUTINE projection (first_band, last_band)
DO i=1,ldim1
u_m(i,i) = u_m(i,i) -1.d0
DO j=1,ldim1
capel = capel + ABS( u_m(i,j) )
END DO
capel = capel + abs( u_m(i,j) )
ENDDO
u_m(i,i) = u_m(i,i) +1.d0
END DO
ENDDO
IF (capel < 1.d-10) THEN
WRITE ( stdout, *) " ORTHOGONALITY CHECK PASSED "
@ -287,8 +287,8 @@ SUBROUTINE projection (first_band, last_band)
WRITE ( stdout, *) " CAPEL = ", capel
DO i=1,ldim1
WRITE ( stdout, '(8(2f5.2,2x))') u_m(:,i)
END DO
END IF
ENDDO
ENDIF
counter = 0
counter_ldaU = 0
DO na = 1, nat
@ -296,34 +296,34 @@ SUBROUTINE projection (first_band, last_band)
DO n = 1, upf(nt)%nwfc
IF (upf(nt)%oc (n) >= 0.d0) THEN
l = upf(nt)%lchi (n)
IF ( (Hubbard_U(nt).NE.0.d0.OR.Hubbard_alpha(nt).NE.0.d0) .AND. &
l.EQ.Hubbard_l(nt) )THEN
IF ( (Hubbard_U(nt)/=0.d0.or.Hubbard_alpha(nt)/=0.d0) .and. &
l==Hubbard_l(nt) )THEN
CALL zgemm( 'N', 'C', npw, 2*l+1, ldim2, ONE, &
evc(1,first_band), npwx, &
pp(counter_ldaU+1,1), ldim1, ZERO, &
wfcatom(1,counter+1), npwx )
counter_ldaU = counter_ldaU + 2 * l + 1
END IF
ENDIF
counter = counter + 2 * l + 1
ENDIF
ENDDO
ENDDO
CALL calbec ( npw, vkb, wfcatom, becp )
CALL s_psi (npwx, npw, natomwfc, wfcatom, swfcatom)
CALL calbec ( npw, vkb, wfcatom, becp )
CALL s_psi (npwx, npw, natomwfc, wfcatom, swfcatom)
CALL davcio (swfcatom, nwordatwfc, iunsat, ik, 1)
! on k-points
ENDDO
!
call deallocate_bec_type (becp)
!
! on k-points
ENDDO
!
CALL deallocate_bec_type (becp)
!
DEALLOCATE (wfcatom)
DEALLOCATE (proj)
RETURN
DEALLOCATE (wfcatom)
DEALLOCATE (proj)
RETURN
END SUBROUTINE projection

38
PP/postproc.f90
View File

@ -38,11 +38,11 @@ PROGRAM pp
!
IF ( ionode ) CALL input_from_file ( )
!
call extract (filplot, plot_num)
CALL extract (filplot, plot_num)
!
call chdens (filplot, plot_num)
CALL chdens (filplot, plot_num)
!
call stop_pp()
CALL stop_pp()
!
END PROGRAM pp
!
@ -91,14 +91,14 @@ SUBROUTINE extract (filplot,plot_num)
!
prefix = 'pwscf'
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
filplot = 'tmp.pp'
IF ( trim( outdir ) == ' ' ) outdir = './'
filplot = 'tmp.pp'
plot_num = -1
spin_component = 0
sample_bias = 0.01d0
z = 1.d0
dz = 0.05d0
lsign=.FALSE.
lsign=.false.
emin = -999.0d0
emax = +999.0d0
epsilon=1.d0
@ -113,11 +113,11 @@ SUBROUTINE extract (filplot,plot_num)
!
tmp_dir = trimcheck ( outdir )
!
END IF
ENDIF
!
call mp_bcast (ios, ionode_id)
CALL mp_bcast (ios, ionode_id)
!
IF ( ios /= 0) CALL errore ('postproc', 'reading inputpp namelist', ABS(ios))
IF ( ios /= 0) CALL errore ('postproc', 'reading inputpp namelist', abs(ios))
!
! ... Broadcast variables
!
@ -138,21 +138,21 @@ SUBROUTINE extract (filplot,plot_num)
!
! no task specified: do nothing and return
!
IF (plot_num == -1) return
IF (plot_num == -1) RETURN
!
IF (plot_num < 0 .OR. plot_num > 18) CALL errore ('postproc', &
'Wrong plot_num', ABS (plot_num) )
IF (plot_num < 0 .or. plot_num > 18) CALL errore ('postproc', &
'Wrong plot_num', abs (plot_num) )
IF (plot_num == 7 .OR. plot_num == 13 .OR. plot_num==18) THEN
IF (spin_component < 0 .OR. spin_component > 3) CALL errore &
IF (plot_num == 7 .or. plot_num == 13 .or. plot_num==18) THEN
IF (spin_component < 0 .or. spin_component > 3) CALL errore &
('postproc', 'wrong spin_component', 1)
ELSE IF (plot_num == 10) THEN
IF (spin_component < 0 .OR. spin_component > 2) CALL errore &
ELSEIF (plot_num == 10) THEN
IF (spin_component < 0 .or. spin_component > 2) CALL errore &
('postproc', 'wrong spin_component', 2)
ELSE
IF (spin_component < 0 ) CALL errore &
('postproc', 'wrong spin_component', 3)
END IF
ENDIF
!
! Now allocate space for pwscf variables, read and check them.
!
@ -168,7 +168,7 @@ SUBROUTINE extract (filplot,plot_num)
CALL errore('postproc',&
'pw.x run with a different number of pools. Use wf_collect=.true.',1)
IF ( ( two_fermi_energies .or. i_cons /= 0) .AND. &
IF ( ( two_fermi_energies .or. i_cons /= 0) .and. &
( plot_num==3 .or. plot_num==4 .or. plot_num==5 ) ) &
CALL errore('postproc',&
'Post-processing with constrained magnetization is not available yet',1)
@ -187,7 +187,7 @@ SUBROUTINE extract (filplot,plot_num)
IF (plot_num == 10) THEN
emin = emin / 13.6058d0
emax = emax / 13.6058d0
END IF
ENDIF
!
!
! Now do whatever you want

3460
PP/projwfc.f90
View File

File diff suppressed because it is too large Load Diff

78
PP/punch_plot.f90
View File

@ -22,7 +22,7 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
USE constants, ONLY : rytoev
USE cell_base, ONLY : at, bg, omega, alat, celldm, ibrav
USE ions_base, ONLY : nat, ntyp => nsp, ityp, tau, zv, atm
USE printout_base, ONLY : title
USE printout_base, ONLY : title
USE extfield, ONLY : tefield, dipfield
USE gvect
USE klist, ONLY : nks, nkstot, xk
@ -54,18 +54,18 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
IF (filplot == ' ') RETURN
#ifdef __PARA
ALLOCATE (raux1( nrx1 * nrx2 * nrx3))
ALLOCATE (raux1( nrx1 * nrx2 * nrx3))
#endif
WRITE( stdout, '(/5x,"Calling punch_plot, plot_num = ",i3)') plot_num
IF (plot_num == 7 ) &
WRITE( stdout, '(/5x,"Plotting k_point = ",i3," band =", i3 )') &
kpoint, kband
IF (plot_num == 7 .AND. noncolin .AND. spin_component .NE. 0 ) &
IF (plot_num == 7 .and. noncolin .and. spin_component /= 0 ) &
WRITE( stdout, '(/5x,"Plotting spin magnetization ipol = ",i3)') &
spin_component
!
ALLOCATE (raux( nrxx))
ALLOCATE (raux( nrxx))
!
! Here we decide which quantity to plot
!
@ -74,7 +74,7 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
! plot of the charge density
!
IF (noncolin) THEN
call dcopy (nrxx, rho%of_r, 1, raux, 1)
CALL dcopy (nrxx, rho%of_r, 1, raux, 1)
ELSE
IF (spin_component == 0) THEN
CALL dcopy (nrxx, rho%of_r (1, 1), 1, raux, 1)
@ -93,7 +93,7 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
! The total self-consistent potential V_H+V_xc on output
!
IF (noncolin) THEN
call dcopy (nrxx, v%of_r, 1, raux, 1)
CALL dcopy (nrxx, v%of_r, 1, raux, 1)
ELSE
IF (spin_component == 0) THEN
CALL dcopy (nrxx, v%of_r, 1, raux, 1)
@ -118,19 +118,19 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
!
! The local density of states at e_fermi on output
!
if (noncolin) call errore('punch_plot','not implemented yet',1)
IF (noncolin) CALL errore('punch_plot','not implemented yet',1)
CALL local_dos (1, lsign, kpoint, kband, spin_component, emin, emax, raux)
ELSEIF (plot_num == 4) THEN
!
! The local density of electronic entropy on output
!
if (noncolin) call errore('punch_plot','not implemented yet',1)
IF (noncolin) CALL errore('punch_plot','not implemented yet',1)
CALL local_dos (2, lsign, kpoint, kband, spin_component, emin, emax, raux)
ELSEIF (plot_num == 5) THEN
if (noncolin) call errore('punch_plot','not implemented yet',1)
IF (noncolin) CALL errore('punch_plot','not implemented yet',1)
CALL work_function (wf)
#ifdef __PARA
CALL stm (wf, sample_bias, z, dz, raux1)
@ -138,7 +138,7 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
CALL stm (wf, sample_bias, z, dz, raux)
#endif
WRITE (title, '(" Bias in eV = ",f10.4," # states",i4)') &
sample_bias * rytoev, NINT (wf)
sample_bias * rytoev, nint (wf)
ELSEIF (plot_num == 6) THEN
!
@ -161,16 +161,16 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
ENDIF
ELSE
CALL local_dos (0, lsign, kpoint, kband, spin_component, emin, emax, raux)
END IF
ENDIF
ELSEIF (plot_num == 8) THEN
if (noncolin) &
call errore('punch_plot','elf+noncolin not yet implemented',1)
IF (noncolin) &
CALL errore('punch_plot','elf+noncolin not yet implemented',1)
CALL do_elf (raux)
ELSEIF (plot_num == 9) THEN
call errore('punch_plot','no longer implemented, see PP/plan_avg.f90',1)
CALL errore('punch_plot','no longer implemented, see PP/plan_avg.f90',1)
ELSEIF (plot_num == 10) THEN
@ -178,14 +178,14 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
ELSEIF (plot_num == 11) THEN
raux(:) = vltot(:)
raux(:) = vltot(:)
IF (nspin == 2) THEN
rho%of_g(:,1) = rho%of_g(:,1) + rho%of_g(:,2)
rho%of_r (:,1) = rho%of_r (:,1) + rho%of_r (:,2)
nspin = 1
END IF
ENDIF
CALL v_h (rho%of_g, ehart, charge, raux)
IF (tefield.AND.dipfield) CALL add_efield(raux,dummy,rho%of_r,.true.)
IF (tefield.and.dipfield) CALL add_efield(raux,dummy,rho%of_r,.true.)
ELSEIF (plot_num == 12) THEN
@ -200,8 +200,8 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
IF (noncolin) THEN
IF (spin_component==0) THEN
raux(:) = SQRT(rho%of_r(:,2)**2 + rho%of_r(:,3)**2 + rho%of_r(:,4)**2 )
ELSEIF (spin_component >= 1 .OR. spin_component <=3) THEN
raux(:) = sqrt(rho%of_r(:,2)**2 + rho%of_r(:,3)**2 + rho%of_r(:,4)**2 )
ELSEIF (spin_component >= 1 .or. spin_component <=3) THEN
raux(:) = rho%of_r(:,spin_component+1)
ELSE
CALL errore('punch_plot','spin_component not allowed',1)
@ -210,13 +210,13 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
CALL errore('punch_plot','noncollinear spin required',1)
ENDIF
ELSEIF (plot_num == 14 .OR. plot_num == 15 .OR. plot_num == 16 ) THEN
ELSEIF (plot_num == 14 .or. plot_num == 15 .or. plot_num == 16 ) THEN
ipol = plot_num - 13
call polarization ( spin_component, ipol, epsilon, raux )
CALL polarization ( spin_component, ipol, epsilon, raux )
ELSEIF (plot_num == 17) THEN
write(stdout, '(7x,a)') "Reconstructing all-electron valence charge."
WRITE(stdout, '(7x,a)') "Reconstructing all-electron valence charge."
! code partially duplicate from plot_num=0, should be unified
CALL PAW_make_ae_charge(rho)
!
@ -234,8 +234,8 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
IF (noncolin) THEN
IF (spin_component==0) THEN
raux(:) = SQRT(v%of_r(:,2)**2 + v%of_r(:,3)**2 + v%of_r(:,4)**2 )
ELSEIF (spin_component >= 1 .OR. spin_component <=3) THEN
raux(:) = sqrt(v%of_r(:,2)**2 + v%of_r(:,3)**2 + v%of_r(:,4)**2 )
ELSEIF (spin_component >= 1 .or. spin_component <=3) THEN
raux(:) = v%of_r(:,spin_component+1)
ELSE
CALL errore('punch_plot','spin_component not allowed',1)
@ -250,7 +250,7 @@ SUBROUTINE punch_plot (filplot, plot_num, sample_bias, z, dz, &
ENDIF
#ifdef __PARA
IF (.NOT. (plot_num == 5 ) ) CALL grid_gather (raux, raux1)
IF (.not. (plot_num == 5 ) ) CALL grid_gather (raux, raux1)
IF ( ionode ) &
CALL plot_io (filplot, title, nrx1, &
nrx2, nrx3, nr1, nr2, nr3, nat, ntyp, ibrav, celldm, at, gcutm, &
@ -283,35 +283,35 @@ SUBROUTINE polarization ( spin_component, ipol, epsilon, raux )
INTEGER :: spin_component, ipol, ig
REAL(DP) :: epsilon, raux (nrxx)
!
IF (ipol < 1 .OR. ipol > 3) CALL errore('polarization', &
IF (ipol < 1 .or. ipol > 3) CALL errore('polarization', &
'wrong component',1)
!
IF (spin_component == 0) THEN
IF (nspin == 1 .OR. nspin == 4 ) THEN
psic(:) = CMPLX(rho%of_r(:,1), 0.d0,kind=DP)
ELSE IF (nspin == 2) THEN
psic(:) = CMPLX(rho%of_r(:,1) + rho%of_r(:,2), 0.d0,kind=DP)
END IF
ELSE
IF (spin_component > nspin .OR. spin_component < 1) &
IF (nspin == 1 .or. nspin == 4 ) THEN
psic(:) = cmplx(rho%of_r(:,1), 0.d0,kind=DP)
ELSEIF (nspin == 2) THEN
psic(:) = cmplx(rho%of_r(:,1) + rho%of_r(:,2), 0.d0,kind=DP)
ENDIF
ELSE
IF (spin_component > nspin .or. spin_component < 1) &
CALL errore('polarization', 'wrong spin component',1)
psic(:) = CMPLX(rho%of_r(:,spin_component), 0.d0,kind=DP)
END IF
psic(:) = cmplx(rho%of_r(:,spin_component), 0.d0,kind=DP)
ENDIF
!
! transform to G space
!
call cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
CALL cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
IF (gstart == 2) psic (1) = (epsilon - 1.d0) / fpi
DO ig = gstart, ngm
psic (nl (ig) ) = psic (nl (ig) ) * g (ipol, ig) / gg (ig) &
/ (0.d0, 1.d0)
if (gamma_only) psic (nlm(ig) ) = CONJG ( psic (nl (ig) ) )
END DO
IF (gamma_only) psic (nlm(ig) ) = conjg ( psic (nl (ig) ) )
ENDDO
!
CALL cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
!
raux (:) = DBLE (psic (:) )
raux (:) = dble (psic (:) )
!
RETURN
!

2
PP/pw2casino_write.f90
View File

@ -387,7 +387,7 @@ CONTAINS
ijkb0 = 0
DO nt = 1, ntyp
DO na = 1, nat
IF(ityp (na) .eq. nt)THEN
IF(ityp (na) == nt)THEN
DO ih = 1, nh (nt)
ikb = ijkb0 + ih
IF(gamma_only)THEN

886
PP/pw2gw.f90
View File

File diff suppressed because it is too large Load Diff

3090
PP/pw2wannier90.f90
View File

File diff suppressed because it is too large Load Diff

730
PP/pw_export.f90
View File

File diff suppressed because it is too large Load Diff

1262
PP/qexml.f90
View File

File diff suppressed because it is too large Load Diff

58
PP/qexml_example.f90
View File

@ -12,7 +12,7 @@
!
! Simple example to show how to use the QEXML library
! to read data from the .save directory written by QE
!
!
! General comments:
!
! - first init the library
@ -22,7 +22,7 @@
! and finally read the data with a second call
! to the proper qexml read routine
! (shown below)
!
!
! - data that don't need any dynamical allocation
! (scalar or small arrays) can be read directly
!
@ -38,7 +38,7 @@
INTEGER, PARAMETER :: iunit = 10
INTEGER, PARAMETER :: stdin = 5
INTEGER, PARAMETER :: stdout = 6
INTEGER, PARAMETER :: DP=KIND(1.0d0)
INTEGER, PARAMETER :: DP=kind(1.0d0)
!
! input variables
@ -85,7 +85,7 @@
work_dir = './'
!
READ( stdin, INPUT, IOSTAT=ierr)
IF ( ierr/=0 ) CALL errore(subname,'reading INPUT namelist',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'reading INPUT namelist',abs(ierr))
!
!
@ -95,18 +95,18 @@
!
WRITE(stdout, "(/, 'Init QEXML library...')" )
!
dirname = TRIM(work_dir) // '/' // TRIM(prefix) // '.save/'
dirname = trim(work_dir) // '/' // trim(prefix) // '.save/'
CALL qexml_init( iunit, DIR=dirname )
filename = TRIM(dirname) // "data-file.xml"
filename = trim(dirname) // "data-file.xml"
!
CALL qexml_openfile( filename, "read", IERR=ierr )
IF ( ierr/=0) CALL errore(subname,'opening dftdata file',ABS(ierr))
IF ( ierr/=0) CALL errore(subname,'opening dftdata file',abs(ierr))
!
!==========================
! read lattice data
! read lattice data
!==========================
! how to read data directly
! units can be read as well
@ -116,12 +116,12 @@
CALL qexml_read_cell( ALAT=alat, &
A1=avec(:,1), A2=avec(:,2), A3=avec(:,3), &
A_UNITS=str_units, IERR=ierr)
IF (ierr/=0) CALL errore(subname,'reading lattice',ABS(ierr))
IF (ierr/=0) CALL errore(subname,'reading lattice',abs(ierr))
!
! reports to stdout
!
WRITE(stdout, "(2x,' Direct lattice [',a,']')") TRIM(str_units)
WRITE(stdout, "(2x,' Direct lattice [',a,']')") trim(str_units)
WRITE(stdout, "(2x,' alat: ',f15.9)") alat
WRITE(stdout, "(2x,' a(1): ',3f15.9)") avec(:,1)
WRITE(stdout, "(2x,' a(2): ',3f15.9)") avec(:,2)
@ -144,21 +144,21 @@
WRITE(stdout, "(/, 'Read main G grid...')" )
!
CALL qexml_read_planewaves( NGM=ngm, IERR=ierr )
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading PW dims',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading PW dims',abs(ierr))
!
ALLOCATE( igv(3,ngm), STAT=ierr )
IF ( ierr/=0 ) CALL errore(subname,'allocating igv',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'allocating igv',abs(ierr))
!
CALL qexml_read_planewaves( IGV=igv, IERR=ierr )
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading main G grid',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading main G grid',abs(ierr))
!
!
WRITE(stdout, "(2x, ' Main grid dim: ',i5)" ) ngm
WRITE(stdout, "(2x, ' Reporting the first 10 elements (check gvectors.dat)')" )
WRITE(stdout, "(2x, ' Reporting the first 10 elements (check gvectors.dat)')" )
DO ig = 1, 10
WRITE(stdout, "(2x, ' ig(',i3, ') : ',3i5 )" ) ig, igv(:,ig)
ENDDO
!
! now read data specific to a given kpt
@ -166,17 +166,17 @@
WRITE(stdout, "(/, 'Read ik-specific dims...')" )
!
CALL qexml_read_gk( ik, NPWK=npw, IERR=ierr )
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading ik dims',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading ik dims',abs(ierr))
!
ALLOCATE( igk(npw), STAT=ierr )
IF ( ierr/=0 ) CALL errore(subname,'allocating igk',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'allocating igk',abs(ierr))
!
! the second dimension is the # of bands to be read
ALLOCATE( wfc(npw,1), STAT=ierr )
IF ( ierr/=0 ) CALL errore(subname,'allocating wfc',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'allocating wfc',abs(ierr))
!
CALL qexml_read_gk( ik, INDEX=igk, IERR=ierr )
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading k-grid map',ABS(ierr))
CALL qexml_read_gk( ik, index=igk, IERR=ierr )
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading k-grid map',abs(ierr))
!
WRITE(stdout, "(2x, ' ik:',i3,' dim: ',i5)" ) ik, npw
@ -191,16 +191,16 @@
WRITE(stdout, "(/, 'Read a given wfc...')" )
!
CALL qexml_read_wfc( IBNDS=ib, IBNDE=ib, IK=ik, WF=wfc, IERR=ierr)
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading ',ABS(ierr))
IF ( ierr/=0 ) CALL errore(subname,'QEXML reading ',abs(ierr))
!
! report to stdout
!
WRITE(stdout, "(2x, ' ik:',i3,' ib: ',i3)" ) ik, ib
WRITE(stdout, "(2x, ' Reporting the first 10 elements (check evc.dat)')" )
WRITE(stdout, "(2x, ' Reporting the first 10 elements (check evc.dat)')" )
DO ig = 1, 10
WRITE(stdout, "(2x, ' ig(',i3, ') : ',2f15.9 )" ) ig, wfc(ig,1)
ENDDO
!
@ -211,8 +211,8 @@
WRITE(stdout, "(/,'Finalize QEXML...')" )
!
CALL qexml_closefile ( "read", IERR=ierr )
IF ( ierr/=0) CALL errore(subname,'closing dftdata file',ABS(ierr))
IF ( ierr/=0) CALL errore(subname,'closing dftdata file',abs(ierr))
!
! local cleanup
@ -232,16 +232,16 @@ CONTAINS
SUBROUTINE errore( calling_routine, message, ierr )
!----------------------------------------------------------------------------
!
! ... This is a simple routine which writes an error message to output:
! ... if ierr <= 0 it does nothing,
! ... This is a simple routine which writes an error message to output:
! ... if ierr <= 0 it does nothing,
! ... if ierr > 0 it stops.
!
IMPLICIT NONE
!
CHARACTER(LEN=*), INTENT(IN) :: calling_routine, message
CHARACTER(len=*), INTENT(in) :: calling_routine, message
! the name of the calling calling_routinee
! the output messagee
INTEGER, INTENT(IN) :: ierr
INTEGER, INTENT(in) :: ierr
! the error flag
!
!

14
PP/smallgk.f90
View File

@ -16,7 +16,7 @@ SUBROUTINE smallgk (xk, at, bg, s, ftau, t_rev, sname, nsym, sk, ftauk, gk, &
!
USE kinds, ONLY : DP
IMPLICIT NONE
CHARACTER(LEN=45) :: snamek(48), sname(48)
CHARACTER(len=45) :: snamek(48), sname(48)
REAL(DP) :: bg (3, 3), at (3, 3), xk (3)
! input: the reciprocal lattice vectors
@ -60,25 +60,25 @@ INTEGER :: s (3, 3, 48), ftau(3,48), t_rev(48), nsym, sk (3, 3, 48), &
rak = 0.d0
DO ipol = 1, 3
DO jpol = 1, 3
rak (ipol) = rak (ipol) + DBLE (s (ipol, jpol, isym) ) * &
rak (ipol) = rak (ipol) + dble (s (ipol, jpol, isym) ) * &
ak (jpol)
ENDDO
ENDDO
IF ((t_rev(isym)==0 .AND. eqvect(rak, ak, zero)) .OR. &
(t_rev(isym)==1 .AND. eqvect(rak, -ak, zero)) ) THEN
IF ((t_rev(isym)==0 .and. eqvect(rak, ak, zero)) .or. &
(t_rev(isym)==1 .and. eqvect(rak, -ak, zero)) ) THEN
nsymk=nsymk+1
sk(:,:,nsymk)=s(:,:,isym)
ftauk(:,nsymk)=ftau(:,isym)
snamek(nsymk)=sname(isym)
t_revk(nsymk)=t_rev(isym)
IF (t_rev(isym)==0) THEN
gk(:,nsymk)=NINT(rak(:)-ak(:))
gk(:,nsymk)=nint(rak(:)-ak(:))
ELSEIF (t_rev(isym)==1) THEN
gk(:,nsymk)=NINT(rak(:)+ak(:))
gk(:,nsymk)=nint(rak(:)+ak(:))
ELSE
CALL errore('smallgk','wrong t_rev',1)
ENDIF
END IF
ENDIF
ENDDO
!
RETURN

152
PP/stm.f90
View File

@ -7,7 +7,7 @@
!
!
!--------------------------------------------------------------------
subroutine stm (wf, sample_bias, z, dz, stmdos)
SUBROUTINE stm (wf, sample_bias, z, dz, stmdos)
!--------------------------------------------------------------------
!
! This routine calculates an stm image defined as the local density
@ -35,19 +35,19 @@ subroutine stm (wf, sample_bias, z, dz, stmdos)
USE io_files, ONLY: iunwfc, nwordwfc
USE constants, ONLY : degspin
USE mp, ONLY : mp_max, mp_min, mp_sum
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
USE fft_base, ONLY : grid_gather
!
implicit none
IMPLICIT NONE
real(DP) :: sample_bias, z, dz, stmdos (nrx1 * nrx2 * nrx3)
! the stm density of states
!
! And here the local variables
!
logical :: uguale
LOGICAL :: uguale
integer :: istates, igs, npws, ir, irx, iry, irz, ig, ibnd, &
INTEGER :: istates, igs, npws, ir, irx, iry, irz, ig, ibnd, &
ik, nbnd_ocp, first_band, last_band
! the number of states to compute the image
! counter on surface g vectors
@ -62,19 +62,19 @@ subroutine stm (wf, sample_bias, z, dz, stmdos)
real(DP) :: emin, emax, fac, wf, wf1, x, y, zz, &
w1, w2, up, up1, down, down1, t0, scnds
complex(DP), parameter :: i= (0.d0, 1.d0)
COMPLEX(DP), PARAMETER :: i= (0.d0, 1.d0)
real(DP), allocatable :: gs (:,:)
complex(DP), allocatable :: a (:), psi (:,:)
real(DP), ALLOCATABLE :: gs (:,:)
COMPLEX(DP), ALLOCATABLE :: a (:), psi (:,:)
! the coefficients of the matching wfc
! plane stm wfc
real(DP), external :: w0gauss
real(DP), EXTERNAL :: w0gauss
t0 = scnds ()
allocate (gs( 2, npwx))
allocate (a ( npwx))
allocate (psi(nrx1, nrx2))
ALLOCATE (gs( 2, npwx))
ALLOCATE (a ( npwx))
ALLOCATE (psi(nrx1, nrx2))
!
stmdos(:) = 0.d0
rho%of_r(:,:) = 0.d0
@ -82,28 +82,28 @@ subroutine stm (wf, sample_bias, z, dz, stmdos)
WRITE( stdout, '(5x,"Sample bias =",f8.4, &
& " eV")') sample_bias * rytoev
!
if (.not.lgauss) then
IF (.not.lgauss) THEN
!
! for semiconductors, add small broadening
!
nbnd_ocp = nint (nelec) / degspin
if (nbnd.le.nbnd_ocp + 1) call errore ('stm', 'not enough bands', 1)
IF (nbnd<=nbnd_ocp + 1) CALL errore ('stm', 'not enough bands', 1)
emin = et (nbnd_ocp + 1, 1)
do ik = 2, nks
DO ik = 2, nks
emin = min (emin, et (nbnd_ocp + 1, ik) )
enddo
ENDDO
#ifdef __PARA
! find the minimum across pools
call mp_min( emin, inter_pool_comm )
CALL mp_min( emin, inter_pool_comm )
#endif
emax = et (nbnd_ocp, 1)
do ik = 2, nks
DO ik = 2, nks
emax = max (emax, et (nbnd_ocp, ik) )
enddo
ENDDO
#ifdef __PARA
! find the maximum across pools
call mp_max( emax, inter_pool_comm )
CALL mp_max( emax, inter_pool_comm )
#endif
ef = (emin + emax) * 0.5d0
degauss = 0.00001d0
@ -112,51 +112,51 @@ subroutine stm (wf, sample_bias, z, dz, stmdos)
WRITE( stdout, '(/5x,"Occupied bands: ",i6)') nbnd_ocp
WRITE( stdout, '(/5x," Fermi energy: ",f10.2," eV")') ef * rytoev
WRITE( stdout, '(/5x," Gap energy: ",f10.2," eV")') (emax - emin) * rytoev
endif
ENDIF
!
! take only the states in the energy window above or below the fermi
! energy as determined by the bias of the sample
!
if (sample_bias.gt.0) then
IF (sample_bias>0) THEN
up = ef + sample_bias
down = ef
else
ELSE
up = ef
down = ef + sample_bias
endif
ENDIF
up1 = up + 3.d0 * degauss
down1 = down - 3.d0 * degauss
do ik = 1, nks
do ibnd = 1, nbnd
if (et (ibnd, ik) > down .and. et (ibnd, ik) < up) then
DO ik = 1, nks
DO ibnd = 1, nbnd
IF (et (ibnd, ik) > down .and. et (ibnd, ik) < up) THEN
wg (ibnd, ik) = wk (ik)
elseif (et (ibnd, ik) < down) then
ELSEIF (et (ibnd, ik) < down) THEN
wg (ibnd, ik) = wk (ik) * w0gauss ( (down - et (ibnd, ik) ) &
/ degauss, ngauss)
elseif (et (ibnd, ik) > up) then
ELSEIF (et (ibnd, ik) > up) THEN
wg (ibnd, ik) = wk (ik) * w0gauss ( (up - et (ibnd, ik) ) &
/ degauss, ngauss)
endif
enddo
enddo
ENDIF
ENDDO
ENDDO
!
istates = 0
!
! here we sum for each k point the contribution
! of the wavefunctions to the stm dos
!
do ik = 1, nks
DO ik = 1, nks
DO ibnd = 1, nbnd
if (et(ibnd,ik) < down1) first_band= ibnd+1
if (et(ibnd,ik) < up1) last_band = ibnd
END DO
IF (et(ibnd,ik) < down1) first_band= ibnd+1
IF (et(ibnd,ik) < up1) last_band = ibnd
ENDDO
istates = istates + (last_band - first_band + 1)
call gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
call davcio (evc, nwordwfc, iunwfc, ik, - 1)
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
!
if (gamma_only) then
IF (gamma_only) THEN
!
! gamma only version of STM.
! Two bands computed in a single FT as in the main (PW) code
@ -170,32 +170,32 @@ subroutine stm (wf, sample_bias, z, dz, stmdos)
!!! WRITE( stdout, * ) w2, ibnd+1, ik
ELSE
w2= 0.d0
END IF
ENDIF
!
! Compute the contribution of these states only if needed
!
psic(:) = (0.d0, 0.d0)
IF ( ibnd < last_band ) THEN
do ig = 1, npw
DO ig = 1, npw
psic(nl(igk(ig))) = &
evc(ig,ibnd) + (0.D0,1.D0) * evc(ig,ibnd+1)
psic(nlm(igk(ig))) = &
CONJG( evc(ig,ibnd) - (0.D0,1.D0) * evc(ig,ibnd+1) )
enddo
conjg( evc(ig,ibnd) - (0.D0,1.D0) * evc(ig,ibnd+1) )
ENDDO
ELSE
do ig = 1, npw
DO ig = 1, npw
psic(nl (igk(ig))) = evc(ig,ibnd)
psic(nlm(igk(ig))) = CONJG( evc(ig,ibnd) )
end do
END IF
psic(nlm(igk(ig))) = conjg( evc(ig,ibnd) )
ENDDO
ENDIF
call cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
do ir = 1, nrxx
rho%of_r (ir, 1) = rho%of_r (ir, 1) + w1* DBLE( psic(ir) )**2 + &
w2*AIMAG( psic(ir) )**2
enddo
END DO
else
CALL cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
DO ir = 1, nrxx
rho%of_r (ir, 1) = rho%of_r (ir, 1) + w1* dble( psic(ir) )**2 + &
w2*aimag( psic(ir) )**2
ENDDO
ENDDO
ELSE
!
! k-point version of STM.
!
@ -207,55 +207,55 @@ subroutine stm (wf, sample_bias, z, dz, stmdos)
! Compute the contribution of this state only if needed
!
psic(:) = (0.d0, 0.d0)
do ig = 1, npw
DO ig = 1, npw
psic(nl(igk(ig))) = evc(ig,ibnd)
end do
ENDDO
call cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
do ir = 1, nrxx
CALL cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
DO ir = 1, nrxx
rho%of_r (ir, 1) = rho%of_r (ir, 1) + w1 * &
( DBLE(psic (ir) ) **2 + AIMAG(psic (ir) ) **2)
enddo
END DO
end if
enddo
( dble(psic (ir) ) **2 + aimag(psic (ir) ) **2)
ENDDO
ENDDO
ENDIF
ENDDO
#ifdef __PARA
call mp_sum( rho%of_r, inter_pool_comm )
CALL mp_sum( rho%of_r, inter_pool_comm )
#endif
!
! symmetrization of the stm dos
!
IF ( .NOT. gamma_only) THEN
IF ( .not. gamma_only) THEN
!
CALL sym_rho_init (gamma_only)
CALL sym_rho_init (gamma_only)
!
psic(:) = CMPLX ( rho%of_r(:,1), 0.0_dp, KIND=dp)
psic(:) = cmplx ( rho%of_r(:,1), 0.0_dp, kind=dp)
CALL cft3s (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, -1)
rho%of_g(:,1) = psic(nl(:))
CALL sym_rho (1, rho%of_g)
psic(:) = (0.0_dp, 0.0_dp)
psic(nl(:)) = rho%of_g(:,1)
CALL cft3s (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
rho%of_r(:,1) = DBLE(psic(:))
END IF
rho%of_r(:,1) = dble(psic(:))
ENDIF
#ifdef __PARA
call grid_gather (rho%of_r(:,1), stmdos)
CALL grid_gather (rho%of_r(:,1), stmdos)
#else
stmdos(:) = rho%of_r(:,1)
#endif
deallocate(psi)
deallocate(a)
deallocate(gs)
DEALLOCATE(psi)
DEALLOCATE(a)
DEALLOCATE(gs)
WRITE( stdout, '(/5x,"STM:",f10.2,"s cpu time")') scnds ()-t0
!
! use wf to store istates
!
wf = istates
#ifdef __PARA
call mp_sum( wf, inter_pool_comm )
CALL mp_sum( wf, inter_pool_comm )
#endif
z = z / alat
dz = dz / alat
return
end subroutine stm
RETURN
END SUBROUTINE stm

34
PP/stop_pp.f90
View File

@ -6,33 +6,33 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
!--------------------------------------------------------------------
subroutine stop_pp
SUBROUTINE stop_pp
!--------------------------------------------------------------------
!
! Synchronize processes before stopping.
!
use control_flags, only: twfcollect
use io_files, only: iunwfc
use mp_global, only: mp_global_end
USE control_flags, ONLY: twfcollect
USE io_files, ONLY: iunwfc
USE mp_global, ONLY: mp_global_end
USE parallel_include
#ifdef __PARA
integer :: info
logical :: op
INTEGER :: info
LOGICAL :: op
inquire ( iunwfc, opened = op )
INQUIRE ( iunwfc, opened = op )
if ( op ) then
if (twfcollect) then
close (unit = iunwfc, status = 'delete')
else
close (unit = iunwfc, status = 'keep')
end if
end if
IF ( op ) THEN
IF (twfcollect) THEN
CLOSE (unit = iunwfc, status = 'delete')
ELSE
CLOSE (unit = iunwfc, status = 'keep')
ENDIF
ENDIF
call mp_global_end()
CALL mp_global_end()
#endif
stop
end subroutine stop_pp
STOP
END SUBROUTINE stop_pp

90
PP/sumpdos.f90
View File

@ -33,11 +33,11 @@ PROGRAM sumpdos
CHARACTER(10) :: cdum, str1, str2
LOGICAL :: exist
REAL :: efermi = 0.0d0 ! translate the input grid
REAL, ALLOCATABLE :: pdos(:,:,:)
REAL :: efermi = 0.0d0 ! translate the input grid
REAL, ALLOCATABLE :: pdos(:,:,:)
REAL, ALLOCATABLE :: egrid(:)
REAL, ALLOCATABLE :: mysum(:,:)
INTEGER :: ios, ierr, iarg, ie, isp, ifile, i
@ -59,12 +59,12 @@ efermi = 0.0d0
CALL getarg ( 1, str1 )
!
SELECT CASE ( TRIM(str1) )
SELECT CASE ( trim(str1) )
CASE ( "-h" )
!
! write the manual
!
WRITE(0,"(/,'USAGE: sumpdos [-h] [-f <filein>] [<file1> ... <fileN>]', /, &
WRITE(0,"(/,'USAGE: sumpdos [-h] [-f <filein>] [<file1> ... <fileN>]', /, &
&' Sum the pdos from the file specified in input and write the sum ', /, &
&' to stdout', /, &
&' -h : write this manual',/, &
@ -79,40 +79,40 @@ efermi = 0.0d0
! read file names from file
!
CALL getarg ( 2, filein )
IF ( LEN_TRIM(filein) == 0 ) CALL errore('sumpdos','provide filein name',2)
INQUIRE( FILE=TRIM(filein), EXIST=exist )
IF (.NOT. exist) CALL errore('sumpdos','file '//TRIM(filein)//' does not exist',3)
OPEN( 10, FILE=TRIM(filein), IOSTAT=ios )
IF (ios/=0) CALL errore('sumpdos','opening '//TRIM(filein),ABS(ios))
IF ( len_trim(filein) == 0 ) CALL errore('sumpdos','provide filein name',2)
INQUIRE( FILE=trim(filein), EXIST=exist )
IF (.not. exist) CALL errore('sumpdos','file '//trim(filein)//' does not exist',3)
OPEN( 10, FILE=trim(filein), IOSTAT=ios )
IF (ios/=0) CALL errore('sumpdos','opening '//trim(filein),abs(ios))
!
! get the number of non-empty lines in the file
! get the number of non-empty lines in the file
! (which is assumed to be the number of files to sum)
!
ios = 0
nfile = 0
nfile = 0
!
DO WHILE ( ios == 0 )
DO WHILE ( ios == 0 )
nfile = nfile + 1
READ(10, *, IOSTAT=ios ) cdum
IF ( ios ==0 .AND. LEN_TRIM(cdum)==0 ) nfile = nfile -1
IF ( ios ==0 .and. len_trim(cdum)==0 ) nfile = nfile -1
ENDDO
nfile = nfile -1
nfile = nfile -1
!
IF (nfile ==0 ) CALL errore('sumpdos','no file to sum in '//TRIM(filein),4)
!
IF (nfile ==0 ) CALL errore('sumpdos','no file to sum in '//trim(filein),4)
!
ALLOCATE( file(nfile), STAT=ierr )
IF (ierr/=0) CALL errore('sumpdos','allocating FILE',ABS(ierr))
IF (ierr/=0) CALL errore('sumpdos','allocating FILE',abs(ierr))
!
REWIND(10)
DO i = 1, nfile
file(i) = ' '
DO WHILE( LEN_TRIM(file(i)) == 0 )
DO WHILE( len_trim(file(i)) == 0 )
READ(10,*, IOSTAT=ios) file(i)
IF (ios /=0 ) CALL errore('sumpdos','reading from '//TRIM(filein),i)
IF (ios /=0 ) CALL errore('sumpdos','reading from '//trim(filein),i)
ENDDO
ENDDO
@ -123,7 +123,7 @@ efermi = 0.0d0
! here we use GETARG
!
ALLOCATE( file(nfile), STAT=ierr )
IF (ierr/=0) CALL errore('sumpdos','allocating FILE',ABS(ierr))
IF (ierr/=0) CALL errore('sumpdos','allocating FILE',abs(ierr))
DO iarg = 1, nfile
CALL getarg ( iarg, file(iarg) )
ENDDO
@ -134,35 +134,35 @@ efermi = 0.0d0
! open the first file and get data about spin
! and grid dimensions
!
INQUIRE( FILE=TRIM(file(1)), EXIST=exist )
IF (.NOT. exist) CALL errore('sumpdos','file '//TRIM(file(1))//' does not exist',3)
INQUIRE( FILE=trim(file(1)), EXIST=exist )
IF (.not. exist) CALL errore('sumpdos','file '//trim(file(1))//' does not exist',3)
!
WRITE(0,"('Reading dimensions from file: ',a)") TRIM(file(1))
WRITE(0,"('Reading dimensions from file: ',a)") trim(file(1))
!
OPEN(10, FILE=TRIM(file(1)), IOSTAT=ios)
IF (ios/=0) CALL errore("sumpdos", "error opening "//TRIM(file(1)), 1)
OPEN(10, FILE=trim(file(1)), IOSTAT=ios)
IF (ios/=0) CALL errore("sumpdos", "error opening "//trim(file(1)), 1)
!
! try to understand if we have 1 or 2 spin
!
READ(10,*, IOSTAT=ios) cdum, cdum, cdum, str1, str2
IF (ios/=0) CALL errore("sumpdos", "reading first line of "//TRIM(file(1)), 1)
IF (ios/=0) CALL errore("sumpdos", "reading first line of "//trim(file(1)), 1)
!
IF ( TRIM(str1) == 'ldos(E)' ) THEN
IF ( trim(str1) == 'ldos(E)' ) THEN
nspin = 1
ELSEIF ( TRIM(str1) == 'ldosup(E)' .AND. TRIM(str2) == 'ldosdw(E)' ) THEN
ELSEIF ( trim(str1) == 'ldosup(E)' .and. trim(str2) == 'ldosdw(E)' ) THEN
nspin = 2
ELSE
CALL errore("sumpdos", "wrong fmf in the first line of "//TRIM(file(1)), 1)
CALL errore("sumpdos", "wrong fmf in the first line of "//trim(file(1)), 1)
ENDIF
!
! determine the dimension fo the energy mesh
!
! determine the dimension fo the energy mesh
! no further control will be done on the consistency of the energy
! grid of each file
!
!
ie = 0
DO WHILE ( .TRUE. )
DO WHILE ( .true. )
READ( 10, *, IOSTAT=ios )
IF ( ios /= 0 ) EXIT
IF ( ios /= 0 ) exit
ie = ie + 1
ENDDO
ngrid = ie
@ -187,24 +187,24 @@ efermi = 0.0d0
!
DO ifile = 1, nfile
!
INQUIRE( FILE=TRIM(file(ifile)), EXIST=exist )
IF (.NOT. exist) &
CALL errore('sumpdos','file '//TRIM(file(ifile))//' does not exist',ifile)
INQUIRE( FILE=trim(file(ifile)), EXIST=exist )
IF (.not. exist) &
CALL errore('sumpdos','file '//trim(file(ifile))//' does not exist',ifile)
!
WRITE(0,"(2x,'Reading file: ',a)") TRIM(file(ifile))
OPEN(10, FILE=TRIM(file(ifile)), IOSTAT=ios)
IF (ios/=0) CALL errore("sumpdos", "error opening "//TRIM(file(ifile)), ios )
WRITE(0,"(2x,'Reading file: ',a)") trim(file(ifile))
OPEN(10, FILE=trim(file(ifile)), IOSTAT=ios)
IF (ios/=0) CALL errore("sumpdos", "error opening "//trim(file(ifile)), ios )
!
READ(10,*, IOSTAT=ios)
IF (ios/=0) &
CALL errore("sumpdos", "reading first line in "//TRIM(file(ifile)), ios )
CALL errore("sumpdos", "reading first line in "//trim(file(ifile)), ios )
!
! egrid is overwritten every time
!
DO ie = 1, ngrid
READ(10, *, IOSTAT=ios ) egrid(ie), pdos(ie, 1:nspin, ifile)
IF (ios/=0) &
CALL errore("sumpdos", "reading first line in "//TRIM(file(ifile)), ie )
CALL errore("sumpdos", "reading first line in "//trim(file(ifile)), ie )
ENDDO
CLOSE(10)
ENDDO
@ -223,7 +223,7 @@ efermi = 0.0d0
mysum = 0.0d0
DO ie=1,ngrid
DO isp=1,nspin
mysum(ie,isp) = SUM( pdos(ie,isp,:) )
mysum(ie,isp) = sum( pdos(ie,isp,:) )
ENDDO
WRITE(6,"(3f15.9)") egrid(ie) - efermi, mysum(ie,1:nspin)
ENDDO

448
PP/sym_band.f90
View File

@ -49,13 +49,13 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
COMPLEX(DP),ALLOCATABLE :: times(:,:,:)
INTEGER, ALLOCATABLE :: rap_et(:,:), code_group_k(:)
INTEGER, ALLOCATABLE :: ngroup(:), istart(:,:)
CHARACTER(LEN=11) :: group_name
CHARACTER(LEN=45) :: snamek(48)
CHARACTER (LEN=256) :: filband, namefile
CHARACTER(len=11) :: group_name
CHARACTER(len=45) :: snamek(48)
CHARACTER (len=256) :: filband, namefile
!
IF (spin_component.NE.1.AND.nspin.NE.2) &
IF (spin_component/=1.and.nspin/=2) &
CALL errore('punch_bands','incorrect spin_component',1)
IF (spin_component<1.OR.spin_component>2) &
IF (spin_component<1.or.spin_component>2) &
CALL errore('punch_bands','incorrect lsda spin_component',1)
ALLOCATE(rap_et(nbnd,nkstot))
@ -71,14 +71,14 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
ios=0
IF ( ionode ) THEN
iunout=58
namefile=TRIM(filband)//".rap"
namefile=trim(filband)//".rap"
OPEN (unit = iunout, file = namefile, status = 'unknown', form = &
'formatted', iostat = ios)
REWIND (iunout)
ENDIF
CALL mp_bcast ( ios, ionode_id )
IF ( ios /= 0) CALL errore ('sym_band', 'Opening filband file', ABS (ios) )
IF ( ios /= 0) CALL errore ('sym_band', 'Opening filband file', abs (ios) )
DO ik = nks1, nks2
!
@ -92,7 +92,7 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
! read eigenfunctions
!
CALL davcio (evc, nwordwfc, iunwfc, ik, - 1)
!
!
! Find the small group of k
!
CALL smallgk (xk(1,ik), at, bg, s, ftau, t_rev, sname, nsym, sk, ftauk, &
@ -115,7 +115,7 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
IF (noncolin) THEN
IF (domag) THEN
CALL find_band_sym_so(evc,et(1,ik),at,nbnd,npw,nsym_is, &
ngm,sk_is,ftau_is,d_spin_is,gk_is,xk(1,ik),igk,nl,nr1,nr2,&
ngm,sk_is,ftau_is,d_spin_is,gk_is,xk(1,ik),igk,nl,nr1,nr2,&
nr3,nrx1,nrx2,nrx3,nrxx,npwx,rap_et(1,ik),times(1,1,ik), &
ngroup(ik),istart(1,ik),accuracy)
ELSE
@ -129,49 +129,49 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
sk, ftauk, gk, xk(1,ik), igk, nl, nr1, nr2, nr3, nrx1, &
nrx2, nrx3, nrxx, npwx, rap_et(1,ik), times(1,1,ik), ngroup(ik),&
istart(1,ik),accuracy)
END IF
ENDIF
100 CONTINUE
END DO
ENDDO
#ifdef __PARA
!
! Only the symmetry of a set of k points is calculated by this
! processor with pool. Here we collect the results into ionode
!
call ipoolrecover(code_group_k,1,nkstot,nks)
call ipoolrecover(rap_et,nbnd,nkstot,nks)
call poolrecover(times,2*24*nbnd,nkstot,nks)
call ipoolrecover(ngroup,1,nkstot,nks)
call ipoolrecover(istart,nbnd+1,nkstot,nks)
CALL ipoolrecover(code_group_k,1,nkstot,nks)
CALL ipoolrecover(rap_et,nbnd,nkstot,nks)
CALL poolrecover(times,2*24*nbnd,nkstot,nks)
CALL ipoolrecover(ngroup,1,nkstot,nks)
CALL ipoolrecover(istart,nbnd+1,nkstot,nks)
#endif
IF (ionode) THEN
is_high_sym=.FALSE.
is_high_sym=.false.
DO ik=nks1tot, nks2tot
CALL smallgk (xk(1,ik), at, bg, s, ftau, t_rev, sname, &
nsym, sk, ftauk, gk, t_revk, snamek, nsymk)
CALL find_info_group(nsymk,sk,t_revk,ftauk,d_spink,gk,snamek,&
sk_is,d_spin_is,gk_is, &
is_symmorphic,search_sym)
if (code_group_k(ik) /= code_group) &
call errore('sym_band','problem with code_group',1)
IF (code_group_k(ik) /= code_group) &
CALL errore('sym_band','problem with code_group',1)
WRITE(stdout, '(/,1x,74("*"))')
WRITE(stdout, '(/,20x,"xk=(",2(f10.5,","),f10.5," )")') &
xk(1,ik), xk(2,ik), xk(3,ik)
IF (.not.search_sym) THEN
WRITE(stdout,'(/,5x,"zone border point and non-symmorphic group ")')
WRITE(stdout,'(5x,"symmetry decomposition not available")')
WRITE(stdout,'(/,5x,"zone border point and non-symmorphic group ")')
WRITE(stdout,'(5x,"symmetry decomposition not available")')
WRITE(stdout, '(/,1x,74("*"))')
ENDIF
IF (ik == nks1tot) then
IF (ik == nks1tot) THEN
WRITE (iunout, '(" &plot_rap nbnd_rap=",i4,", nks_rap=",i4," /")') &
nbnd, nks2tot-nks1tot+1
if (search_sym) CALL write_group_info(.true.)
IF (search_sym) CALL write_group_info(.true.)
is_high_sym=.true.
ELSE
IF (code_group_k(ik).ne.code_group_k(ik-1).and.search_sym) &
IF (code_group_k(ik)/=code_group_k(ik-1).and.search_sym) &
CALL write_group_info(.true.)
is_high_sym= (code_group_k(ik).ne.code_group_k(ik-1)) &
is_high_sym= (code_group_k(ik)/=code_group_k(ik-1)) &
.and..not.is_high_sym
ENDIF
WRITE (iunout, '(10x,3f10.6,l5)') xk(1,ik),xk(2,ik),xk(3,ik), &
@ -190,22 +190,22 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
ELSE
WRITE(stdout,'(/,5x,"Band symmetry, ",a11," point group:",/)') &
group_name(code_group_k(ik))
END IF
ENDIF
DO igroup=1,ngroup(ik)
dim_rap=istart(igroup+1,ik)-istart(igroup,ik)
DO irap=1,nclass
IF (noncolin) THEN
IF ((ABS(NINT(DBLE(times(igroup,irap,ik)))- &
DBLE(times(igroup,irap,ik))) > accuracy).OR. &
(ABS(AIMAG(times(igroup,irap,ik))) > accuracy) ) THEN
IF ((abs(nint(dble(times(igroup,irap,ik)))- &
dble(times(igroup,irap,ik))) > accuracy).or. &
(abs(aimag(times(igroup,irap,ik))) > accuracy) ) THEN
WRITE(stdout,'(5x,"e(",i3," -",i3,") = ",f12.5,2x,&
&"eV",3x,i3,3x, "--> ?")') &
istart(igroup,ik), istart(igroup+1,ik)-1, &
et(istart(igroup,ik),ik)*rytoev, dim_rap
EXIT
ELSE IF (ABS(times(igroup,irap,ik)) > accuracy) THEN
IF (ABS(NINT(DBLE(times(igroup,irap,ik))-1.d0)) < &
exit
ELSEIF (abs(times(igroup,irap,ik)) > accuracy) THEN
IF (abs(nint(dble(times(igroup,irap,ik))-1.d0)) < &
accuracy) THEN
WRITE(stdout,'(5x, "e(",i3," -",i3,") = ",&
&f12.5,2x,"eV",3x,i3,3x,"--> ",a15)') &
@ -217,20 +217,20 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
&f12.5,2x,"eV",3x,i3,3x,"--> ",i3," ",a15)') &
istart(igroup,ik), istart(igroup+1,ik)-1, &
et(istart(igroup,ik),ik)*rytoev, dim_rap, &
NINT(DBLE(times(igroup,irap,ik))), name_rap_so(irap)
nint(dble(times(igroup,irap,ik))), name_rap_so(irap)
ENDIF
ENDIF
ELSE
IF ((ABS(NINT(DBLE(times(igroup,irap,ik)))- &
DBLE(times(igroup,irap,ik))) > accuracy).OR. &
(ABS(AIMAG(times(igroup,irap,ik))) > accuracy) ) THEN
IF ((abs(nint(dble(times(igroup,irap,ik)))- &
dble(times(igroup,irap,ik))) > accuracy).or. &
(abs(aimag(times(igroup,irap,ik))) > accuracy) ) THEN
WRITE(stdout,'(5x,"e(",i3," -",i3,") = ",f12.5,2x,&
&"eV",3x,i3,3x, "--> ?")') &
istart(igroup,ik), istart(igroup+1,ik)-1, &
et(istart(igroup,ik),ik)*rytoev, dim_rap
EXIT
ELSE IF (ABS(times(igroup,irap,ik)) > accuracy) THEN
IF (ABS(NINT(DBLE(times(igroup,irap,ik))-1.d0)) < &
exit
ELSEIF (abs(times(igroup,irap,ik)) > accuracy) THEN
IF (abs(nint(dble(times(igroup,irap,ik))-1.d0)) < &
accuracy) THEN
WRITE(stdout,'(5x, "e(",i3," -",i3,") = ",&
&f12.5,2x,"eV",3x,i3,3x,"--> ",a15)') &
@ -242,7 +242,7 @@ SUBROUTINE sym_band(filband, spin_component, firstk, lastk)
&f12.5,2x,"eV",3x,i3,3x,"--> ",i3," ",a15)') &
istart(igroup,ik), istart(igroup+1,ik)-1, &
et(istart(igroup,ik),ik)*rytoev, dim_rap, &
NINT(DBLE(times(igroup,irap,ik))), name_rap(irap)
nint(dble(times(igroup,irap,ik))), name_rap(irap)
ENDIF
ENDIF
ENDIF
@ -268,10 +268,10 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
rap_et,times,ngroup,istart,accuracy)
!
! This subroutine finds the irreducible representations which give
! the transformation properties of the wavefunctions.
! the transformation properties of the wavefunctions.
! Presently it does NOT work at zone border if the space group of
! the crystal has fractionary translations (non-symmorphic space groups).
!
!
!
USE io_global, ONLY : stdout
USE kinds, ONLY : DP
@ -286,30 +286,30 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
IMPLICIT NONE
REAL(DP), INTENT(IN) :: accuracy
REAL(DP), INTENT(in) :: accuracy
INTEGER :: nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, ngm, npw, npwx
INTEGER :: &
nsym, &
nsym, &
nbnd, &
rap_et(nbnd), &
igk(npwx), &
nl(ngm), &
ftau(3,48), &
gk(3,48), &
s(3,3,48), &
s(3,3,48), &
ngroup, & ! number of different frequencies groups
istart(nbnd+1)
istart(nbnd+1)
REAL(DP) :: &
at(3,3), &
xk(3), &
et(nbnd)
et(nbnd)
COMPLEX(DP) :: &
times(nbnd,24), &
evc(npwx, nbnd)
evc(npwx, nbnd)
REAL(DP), PARAMETER :: eps=1.d-5
@ -323,7 +323,7 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
shift, &
na, i, j, ig, dimen
COMPLEX(DP) :: zdotc
COMPLEX(DP) :: zdotc
REAL(DP), ALLOCATABLE :: w1(:)
COMPLEX(DP), ALLOCATABLE :: evcr(:,:), trace(:,:)
@ -333,7 +333,7 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
ALLOCATE(w1(nbnd))
ALLOCATE(evcr(npwx,nbnd))
ALLOCATE(trace(48,nbnd))
IF (okvan) call allocate_bec_type ( nkb, nbnd, becp )
IF (okvan) CALL allocate_bec_type ( nkb, nbnd, becp )
rap_et=-1
w1=et*rytoev
@ -341,11 +341,11 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
ngroup=1
istart(ngroup)=1
DO ibnd=2,nbnd
IF (ABS(w1(ibnd)-w1(ibnd-1)) > 0.0001d0) THEN
IF (abs(w1(ibnd)-w1(ibnd-1)) > 0.0001d0) THEN
ngroup=ngroup+1
istart(ngroup)=ibnd
END IF
END DO
ENDIF
ENDDO
istart(ngroup+1)=nbnd+1
!
! Find the character of one symmetry operation per class
@ -363,12 +363,12 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
ftau(1,irot),gk(1,irot),nl,igk,nr1,nr2,nr3,nrx1, &
nrx2,nrx3,nrxx,ngm,npw)
END DO
ENDDO
!
! and apply S if necessary
!
IF ( okvan ) THEN
CALL calbec( npw, vkb, evcr, becp )
CALL calbec( npw, vkb, evcr, becp )
CALL s_psi( npwx, npw, nbnd, evcr, evcr )
ENDIF
!
@ -381,10 +381,10 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
ibnd=istart(igroup)+i-1
trace(iclass,igroup)=trace(iclass,igroup) + &
zdotc(npw,evc(1,ibnd),1,evcr(1,ibnd),1)
END DO
ENDDO
! write(6,*) igroup, iclass, trace(iclass,igroup)
END DO
END DO
ENDDO
ENDDO
!
CALL mp_sum( trace, intra_pool_comm )
@ -410,8 +410,8 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
*nelem(iclass)
ENDDO
times(igroup,irap)=times(igroup,irap)/nsym
IF ((ABS(NINT(DBLE(times(igroup,irap)))-DBLE(times(igroup,irap))) &
> accuracy).OR. (ABS(AIMAG(times(igroup,irap))) > eps) ) THEN
IF ((abs(nint(dble(times(igroup,irap)))-dble(times(igroup,irap))) &
> accuracy).or. (abs(aimag(times(igroup,irap))) > eps) ) THEN
! WRITE(stdout,'(5x,"e(",i3," -",i3,") = ",f12.5,2x,"eV",3x,i3,3x,&
! & "--> ?")') &
! istart(igroup), istart(igroup+1)-1, w1(istart(igroup)), dim_rap
@ -420,18 +420,18 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
DO i=1,dim_rap
ibnd=istart(igroup)+i-1
rap_et(ibnd)=0
END DO
END IF
ENDDO
ENDIF
GOTO 300
ELSE IF (ABS(times(igroup,irap)) > accuracy) THEN
ELSEIF (abs(times(igroup,irap)) > accuracy) THEN
ibnd=istart(igroup)+shift
dimen=NINT(DBLE(char_mat(irap,1)))
dimen=nint(dble(char_mat(irap,1)))
IF (rap_et(ibnd)==-1) THEN
DO i=1,dimen*NINT(DBLE(times(igroup,irap)))
DO i=1,dimen*nint(dble(times(igroup,irap)))
ibnd=istart(igroup)+shift+i-1
rap_et(ibnd)=irap
ENDDO
shift=shift+dimen*NINT(DBLE(times(igroup,irap)))
shift=shift+dimen*nint(dble(times(igroup,irap)))
ENDIF
! IF (ABS(NINT(DBLE(times))-1.d0) < 1.d-4) THEN
! WRITE(stdout,'(5x, "e(",i3," -",i3,") = ",f12.5,2x,"eV",3x,i3,&
@ -444,16 +444,16 @@ SUBROUTINE find_band_sym (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,gk, &
! istart(igroup), istart(igroup+1)-1, &
! w1(istart(igroup)), dim_rap, NINT(DBLE(times)), name_rap(irap)
! END IF
END IF
END DO
ENDIF
ENDDO
300 CONTINUE
END DO
ENDDO
!WRITE( stdout, '(/,1x,74("*"))')
DEALLOCATE(trace)
DEALLOCATE(w1)
DEALLOCATE(evcr)
IF (okvan) call deallocate_bec_type (becp)
IF (okvan) CALL deallocate_bec_type (becp)
RETURN
END SUBROUTINE find_band_sym
@ -485,7 +485,7 @@ SUBROUTINE rotate_psi(evc,evcr,s,ftau,gk,nl,igk,nr1,nr2,nr3, &
ALLOCATE(psic(nrxx))
ALLOCATE(psir(nrxx))
!
zone_border=(gk(1).ne.0.or.gk(2).ne.0.or.gk(3).ne.0)
zone_border=(gk(1)/=0.or.gk(2)/=0.or.gk(3)/=0)
!
psic = ( 0.D0, 0.D0 )
!
@ -507,27 +507,27 @@ SUBROUTINE rotate_psi(evc,evcr,s,ftau,gk,nl,igk,nr1,nr2,nr3, &
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/DBLE(nr1)+(gk(2)*(j-1))/DBLE(nr2)+ &
(gk(3)*(k-1))/DBLE(nr3) )
phase=CMPLX(cos(arg),sin(arg),kind=DP)
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/dble(nr1)+(gk(2)*(j-1))/dble(nr2)+ &
(gk(3)*(k-1))/dble(nr3) )
phase=cmplx(cos(arg),sin(arg),kind=DP)
psir_collect(ir)=psic_collect(rir)*phase
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ELSE
DO k = 1, nr3
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
psir_collect(ir)=psic_collect(rir)
END DO
END DO
END DO
END IF
ENDDO
ENDDO
ENDDO
ENDIF
!
CALL cscatter_sym( psir_collect, psir )
!
@ -541,33 +541,33 @@ SUBROUTINE rotate_psi(evc,evcr,s,ftau,gk,nl,igk,nr1,nr2,nr3, &
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/DBLE(nr1)+(gk(2)*(j-1))/DBLE(nr2)+ &
(gk(3)*(k-1))/DBLE(nr3) )
phase=CMPLX(cos(arg),sin(arg),kind=DP)
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/dble(nr1)+(gk(2)*(j-1))/dble(nr2)+ &
(gk(3)*(k-1))/dble(nr3) )
phase=cmplx(cos(arg),sin(arg),kind=DP)
psir(ir)=psic(rir)*phase
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ELSE
DO k = 1, nr3
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
psir(ir)=psic(rir)
END DO
END DO
END DO
END IF
ENDDO
ENDDO
ENDDO
ENDIF
!
#endif
!
CALL cft3( psir, nr1, nr2, nr3, nrx1, nrx2, nrx3, -1 )
!
evcr(1:npw) = psir(nl(igk(1:npw)))
evcr(1:npw) = psir(nl(igk(1:npw)))
!
DEALLOCATE(psic)
DEALLOCATE(psir)
@ -580,9 +580,9 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
rap_et,times,ngroup,istart,accuracy)
!
! This subroutine finds the irreducible representations of the
! double group which give the transformation properties of the
! spinor wavefunctions evc.
! This subroutine finds the irreducible representations of the
! double group which give the transformation properties of the
! spinor wavefunctions evc.
! Presently it does NOT work at zone border if the space group of
! the crystal has fractionary translations (non-symmorphic space groups).
!
@ -592,7 +592,7 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
USE constants, ONLY : rytoev
USE rap_point_group, ONLY : code_group, nclass, gname
USE rap_point_group_so, ONLY : nrap, nelem_so, elem_so, has_e, which_irr_so, &
char_mat_so, name_rap_so, name_class_so, &
char_mat_so, name_rap_so, name_class_so, &
name_class_so1
USE rap_point_group_is, ONLY : gname_is
USE spin_orb, ONLY : domag
@ -604,31 +604,31 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
IMPLICIT NONE
REAL(DP), INTENT(IN) :: accuracy
REAL(DP), INTENT(in) :: accuracy
INTEGER :: nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, ngm, npw, npwx
INTEGER :: &
nsym, &
nsym, &
nbnd, &
ngroup, &
ngroup, &
istart(nbnd+1), &
rap_et(nbnd), &
igk(npwx), &
nl(ngm), &
ftau(3,48), &
gk(3,48), &
s(3,3,48)
s(3,3,48)
REAL(DP) :: &
at(3,3), &
xk(3), &
et(nbnd)
et(nbnd)
COMPLEX(DP) :: &
times(nbnd,24), &
d_spin(2,2,48), &
evc(npwx*npol, nbnd)
d_spin(2,2,48), &
evc(npwx*npol, nbnd)
REAL(DP), PARAMETER :: eps=1.d-5
@ -642,7 +642,7 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
iclass, &
na, i, j, ig, ipol, jpol, jrap, dimen
COMPLEX(DP) :: zdotc ! moltiplication factors
COMPLEX(DP) :: zdotc ! moltiplication factors
REAL(DP), ALLOCATABLE :: w1(:) ! list of energy eigenvalues in eV
COMPLEX(DP), ALLOCATABLE :: evcr(:,:), & ! the rotated of each wave function
@ -654,7 +654,7 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
ALLOCATE(w1(nbnd))
ALLOCATE(evcr(npwx*npol,nbnd))
ALLOCATE(trace(48,nbnd))
IF (okvan) call allocate_bec_type ( nkb, nbnd, becp )
IF (okvan) CALL allocate_bec_type ( nkb, nbnd, becp )
rap_et=-1
w1=et*rytoev
@ -665,11 +665,11 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
ngroup=1
istart(ngroup)=1
DO ibnd=2,nbnd
IF (ABS(w1(ibnd)-w1(ibnd-1)) > 0.0001d0) THEN
IF (abs(w1(ibnd)-w1(ibnd-1)) > 0.0001d0) THEN
ngroup=ngroup+1
istart(ngroup)=ibnd
END IF
END DO
ENDIF
ENDDO
istart(ngroup+1)=nbnd+1
!
! Find the character of one symmetry operation per class
@ -686,7 +686,7 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
CALL rotate_psi_so(evc(1,ibnd),evcr(1,ibnd),s(1,1,irot), &
ftau(1,irot),d_spin(1,1,irot),has_e(1,iclass),gk(1,irot), &
nl,igk,npol,nr1,nr2,nr3,nrx1,nrx2,nrx3,nrxx,ngm,npw,npwx)
END DO
ENDDO
!
! and apply S in the US case.
!
@ -703,10 +703,10 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
ibnd=istart(igroup)+i-1
trace(iclass,igroup)=trace(iclass,igroup) + &
zdotc(2*npwx,evc(1,ibnd),1,evcr(1,ibnd),1)
END DO
ENDDO
! write(6,*) igroup, iclass, dim_rap, trace(iclass,igroup)
END DO
END DO
ENDDO
ENDDO
!
CALL mp_sum(trace,intra_pool_comm)
!
@ -733,12 +733,12 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
times(igroup,irap)=(0.d0,0.d0)
DO iclass=1,nclass
times(igroup,irap)=times(igroup,irap) &
+CONJG(trace(iclass,igroup))*char_mat_so(irap, &
which_irr_so(iclass))*DBLE(nelem_so(iclass))
+conjg(trace(iclass,igroup))*char_mat_so(irap, &
which_irr_so(iclass))*dble(nelem_so(iclass))
ENDDO
times(igroup,irap)=times(igroup,irap)/2/nsym
IF ((ABS(NINT(DBLE(times(igroup,irap)))-DBLE(times(igroup,irap)))&
> accuracy).OR. (ABS(AIMAG(times(igroup,irap))) > accuracy) ) THEN
IF ((abs(nint(dble(times(igroup,irap)))-dble(times(igroup,irap)))&
> accuracy).or. (abs(aimag(times(igroup,irap))) > accuracy) ) THEN
! WRITE(stdout,'(5x,"e(",i3," -",i3,") = ",f12.5,2x,"eV",3x,i3,3x,&
! & "--> ?")') &
! istart(igroup), istart(igroup+1)-1, w1(istart(igroup)), dim_rap
@ -747,20 +747,20 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
DO i=1,dim_rap
ibnd=istart(igroup)+i-1
rap_et(ibnd)=0
END DO
END IF
ENDDO
ENDIF
GOTO 300
END IF
IF (ABS(times(igroup,irap)) > accuracy) THEN
dimen=NINT(DBLE(char_mat_so(irap,1)))
ENDIF
IF (abs(times(igroup,irap)) > accuracy) THEN
dimen=nint(dble(char_mat_so(irap,1)))
ibnd=istart(igroup) + shift
IF (rap_et(ibnd)==-1) THEN
DO i=1,dimen*NINT(DBLE(times(igroup,irap)))
DO i=1,dimen*nint(dble(times(igroup,irap)))
ibnd=istart(igroup)+shift+i-1
rap_et(ibnd)=irap
END DO
shift=shift+dimen*NINT(DBLE(times(igroup,irap)))
END IF
ENDDO
shift=shift+dimen*nint(dble(times(igroup,irap)))
ENDIF
! IF (ABS(NINT(DBLE(times))-1.d0) < 1.d-4) THEN
! WRITE(stdout,'(5x, "e(",i3," -",i3,") = ",f12.5,2x,"eV",3x,i3,3x,&
! & "--> ",a15)') &
@ -772,16 +772,16 @@ SUBROUTINE find_band_sym_so (evc,et,at,nbnd,npw,nsym,ngm,s,ftau,d_spin,gk, &
! istart(igroup), istart(igroup+1)-1, &
! w1(istart(igroup)), dim_rap, NINT(DBLE(times)), name_rap_so(irap)
! END IF
END IF
END DO
ENDIF
ENDDO
300 CONTINUE
END DO
ENDDO
!WRITE( stdout, '(/,1x,74("*"))')
DEALLOCATE(trace)
DEALLOCATE(w1)
DEALLOCATE(evcr)
IF (okvan) call deallocate_bec_type ( becp )
IF (okvan) CALL deallocate_bec_type ( becp )
RETURN
END SUBROUTINE find_band_sym_so
@ -820,7 +820,7 @@ SUBROUTINE rotate_psi_so(evc_nc,evcr,s,ftau,d_spin,has_e,gk,nl,igk,npol, &
ALLOCATE(psir(nrxx,npol))
ALLOCATE(evcr_save(npwx,npol))
!
zone_border=(gk(1).ne.0.or.gk(2).ne.0.or.gk(3).ne.0)
zone_border=(gk(1)/=0.or.gk(2)/=0.or.gk(3)/=0)
!
psic = ( 0.D0, 0.D0 )
psir = ( 0.D0, 0.D0 )
@ -842,27 +842,27 @@ SUBROUTINE rotate_psi_so(evc_nc,evcr,s,ftau,d_spin,has_e,gk,nl,igk,npol, &
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/DBLE(nr1)+(gk(2)*(j-1))/DBLE(nr2)+ &
(gk(3)*(k-1))/DBLE(nr3) )
phase=CMPLX(cos(arg),sin(arg),kind=DP)
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/dble(nr1)+(gk(2)*(j-1))/dble(nr2)+ &
(gk(3)*(k-1))/dble(nr3) )
phase=cmplx(cos(arg),sin(arg),kind=DP)
psir_collect(ir)=psic_collect(rir)*phase
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ELSE
DO k = 1, nr3
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
psir_collect(ir)=psic_collect(rir)
END DO
END DO
END DO
END IF
ENDDO
ENDDO
ENDDO
ENDIF
!
CALL cscatter_sym( psir_collect, psir(:,ipol) )
!
@ -872,41 +872,41 @@ SUBROUTINE rotate_psi_so(evc_nc,evcr,s,ftau,d_spin,has_e,gk,nl,igk,npol, &
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/DBLE(nr1)+(gk(2)*(j-1))/DBLE(nr2)+ &
(gk(3)*(k-1))/DBLE(nr3) )
phase=CMPLX(COS(arg),SIN(arg),kind=DP)
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
arg=tpi*( (gk(1)*(i-1))/dble(nr1)+(gk(2)*(j-1))/dble(nr2)+ &
(gk(3)*(k-1))/dble(nr3) )
phase=cmplx(cos(arg),sin(arg),kind=DP)
psir(ir,ipol)=psic(rir,ipol)*phase
END DO
END DO
END DO
ENDDO
ENDDO
ENDDO
ELSE
DO k = 1, nr3
DO j = 1, nr2
DO i = 1, nr1
CALL ruotaijk (s, ftau, i, j, k, nr1, nr2, nr3, ri, rj, rk )
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
ir=i+(j-1)*nrx1+(k-1)*nrx1*nrx2
rir=ri+(rj-1)*nrx1+(rk-1)*nrx1*nrx2
psir(ir,ipol)=psic(rir,ipol)
END DO
END DO
END DO
END IF
ENDDO
ENDDO
ENDDO
ENDIF
!
#endif
!
CALL cft3( psir(1,ipol), nr1, nr2, nr3, nrx1, nrx2, nrx3, -1 )
!
evcr_save(1:npw,ipol) = psir(nl(igk(1:npw)),ipol)
evcr_save(1:npw,ipol) = psir(nl(igk(1:npw)),ipol)
!
ENDDO
evcr=(0.d0,0.d0)
DO ipol=1,npol
DO jpol=1,npol
evcr(:,ipol)=evcr(:,ipol)+CONJG(d_spin(jpol,ipol))*evcr_save(:,jpol)
END DO
END DO
evcr(:,ipol)=evcr(:,ipol)+conjg(d_spin(jpol,ipol))*evcr_save(:,jpol)
ENDDO
ENDDO
IF (has_e==-1) evcr=-evcr
!
DEALLOCATE(evcr_save)
@ -921,31 +921,31 @@ END SUBROUTINE rotate_psi_so
SUBROUTINE find_nks1nks2(firstk,lastk,nks1tot,nks1,nks2tot,nks2,spin_component)
!
! This routine selects the first (nks1) and last (nks2) k point calculated
! by the current pool.
! This routine selects the first (nks1) and last (nks2) k point calculated
! by the current pool.
!
USE lsda_mod, ONLY : nspin
USE klist, ONLY : nks, nkstot
USE mp_global, ONLY : my_pool_id, npool, kunit
IMPLICIT NONE
INTEGER, INTENT(OUT) :: nks1tot,nks1,nks2tot,nks2
INTEGER, INTENT(IN) :: firstk, lastk, spin_component
INTEGER, INTENT(out) :: nks1tot,nks1,nks2tot,nks2
INTEGER, INTENT(in) :: firstk, lastk, spin_component
INTEGER :: nbase, rest
IF (nspin==1.OR.nspin==4) THEN
nks1tot=MAX(1,firstk)
nks2tot=MIN(nkstot, lastk)
ELSE IF (nspin.eq.2) THEN
IF (nspin==1.or.nspin==4) THEN
nks1tot=max(1,firstk)
nks2tot=min(nkstot, lastk)
ELSEIF (nspin==2) THEN
IF (spin_component == 1) THEN
nks1tot=MAX(1,firstk)
nks2tot=MIN(nkstot/2,lastk)
ELSE IF (spin_component==2) THEN
nks1tot=nkstot/2 + MAX(1,firstk)
nks2tot=nkstot/2 + MIN(nkstot/2,lastk)
END IF
END IF
IF (nks1tot>nks2tot) call errore('findnks1nks2','wrong nks1tot or nks2tot',1)
nks1tot=max(1,firstk)
nks2tot=min(nkstot/2,lastk)
ELSEIF (spin_component==2) THEN
nks1tot=nkstot/2 + max(1,firstk)
nks2tot=nkstot/2 + min(nkstot/2,lastk)
ENDIF
ENDIF
IF (nks1tot>nks2tot) CALL errore('findnks1nks2','wrong nks1tot or nks2tot',1)
#ifdef __PARA
nks = kunit * ( nkstot / kunit / npool )
@ -958,9 +958,9 @@ SUBROUTINE find_nks1nks2(firstk,lastk,nks1tot,nks1,nks2tot,nks2,spin_component)
nbase = nks * my_pool_id
IF ( ( my_pool_id + 1 ) > rest ) nbase = nbase + rest * kunit
nks1=MAX(1,nks1tot-nbase)
nks1=max(1,nks1tot-nbase)
IF (nks1>nks) nks1=nks+1
nks2=MIN(nks,nks2tot-nbase)
nks2=min(nks,nks2tot-nbase)
IF (nks2<1) nks2=nks1-1
#else
nks1=nks1tot
@ -992,42 +992,42 @@ SUBROUTINE find_info_group(nsym,s,t_rev,ftau,d_spink,gk,sname, &
IMPLICIT NONE
INTEGER, INTENT(IN) :: nsym, & ! dimension of the group
INTEGER, INTENT(in) :: nsym, & ! dimension of the group
s(3,3,48), & ! rotation matrices
t_rev(48), & ! if time reversal is need
ftau(3,48), & ! fractionary translation
gk(3,48)
INTEGER, INTENT(OUT) :: s_is(3,3,48), & ! rotation matrices
INTEGER, INTENT(out) :: s_is(3,3,48), & ! rotation matrices
gk_is(3,48)
COMPLEX(DP),INTENT(OUT) :: d_spink(2,2,48), & ! rotation in spin space
COMPLEX(DP),INTENT(out) :: d_spink(2,2,48), & ! rotation in spin space
d_spin_is(2,2,48) ! rotation in spin space
LOGICAL, INTENT(OUT) :: is_symmorphic, & ! true if the gruop is symmorphic
LOGICAL, INTENT(out) :: is_symmorphic, & ! true if the gruop is symmorphic
search_sym ! true if gk
CHARACTER(LEN=45), INTENT(IN) :: sname(48)
CHARACTER(len=45), INTENT(in) :: sname(48)
REAL(DP) :: sr(3,3,48)
INTEGER :: isym
is_symmorphic=.TRUE.
search_sym=.TRUE.
is_symmorphic=.true.
search_sym=.true.
DO isym=1,nsym
is_symmorphic=( is_symmorphic.AND.(ftau(1,isym)==0).AND. &
(ftau(2,isym)==0).AND. &
is_symmorphic=( is_symmorphic.and.(ftau(1,isym)==0).and. &
(ftau(2,isym)==0).and. &
(ftau(3,isym)==0) )
END DO
ENDDO
IF (.NOT.is_symmorphic) THEN
IF (.not.is_symmorphic) THEN
DO isym=1,nsym
search_sym=( search_sym.AND.(gk(1,isym)==0).AND. &
(gk(2,isym)==0).AND. &
search_sym=( search_sym.and.(gk(1,isym)==0).and. &
(gk(2,isym)==0).and. &
(gk(3,isym)==0) )
END DO
END IF
ENDDO
ENDIF
!
! Set the group name, divide it in classes and set the irreducible
! representations
@ -1049,12 +1049,12 @@ SUBROUTINE find_info_group(nsym,s,t_rev,ftau,d_spink,gk,sname, &
gk_is(:,nsym_is)=gk(:,isym)
ftau_is(:,nsym_is)=ftau(:,isym)
sname_is(nsym_is)=sname(isym)
END IF
ENDIF
ELSE
CALL find_u(sr(1,1,isym),d_spink(1,1,isym))
END IF
END IF
END DO
ENDIF
ENDIF
ENDDO
CALL find_group(nsym,sr,gname,code_group)
IF (noncolin) THEN
IF (domag) THEN
@ -1068,11 +1068,11 @@ SUBROUTINE find_info_group(nsym,s,t_rev,ftau,d_spink,gk,sname, &
name_rap_so,name_class_so,name_class_so1)
CALL divide_class_so(code_group,nsym,sr,d_spink, &
has_e,nclass,nelem_so,elem_so,which_irr_so)
END IF
ENDIF
ELSE
CALL set_irr_rap(code_group,nclass,char_mat,name_rap,name_class,ir_ram)
CALL divide_class(code_group,nsym,sr,nclass,nelem,elem,which_irr)
END IF
ENDIF
RETURN
END SUBROUTINE find_info_group
@ -1085,7 +1085,7 @@ END SUBROUTINE find_info_group
!
!
!----------------------------------------------------------------------
subroutine s_axis_to_cart (s, sr, at, bg)
SUBROUTINE s_axis_to_cart (s, sr, at, bg)
!----------------------------------------------------------------------
!
! This routine transform a symmetry matrix expressed in the
@ -1095,11 +1095,11 @@ subroutine s_axis_to_cart (s, sr, at, bg)
!
!
USE kinds
implicit none
IMPLICIT NONE
!
! first the input parameters
!
integer :: s (3, 3)
INTEGER :: s (3, 3)
! input: matrix in crystal axis
real(DP) :: sr (3, 3), at (3, 3), bg (3, 3)
! output: matrix in cartesian axis
@ -1109,20 +1109,20 @@ subroutine s_axis_to_cart (s, sr, at, bg)
! here the local variable
!
integer :: apol, bpol, kpol, lpol
INTEGER :: apol, bpol, kpol, lpol
!
! counters on polarizations
!
do apol = 1, 3
do bpol = 1, 3
DO apol = 1, 3
DO bpol = 1, 3
sr (apol, bpol) = 0.d0
do kpol = 1, 3
do lpol = 1, 3
DO kpol = 1, 3
DO lpol = 1, 3
sr (apol, bpol) = sr (apol, bpol) + at (apol, kpol) * &
DBLE ( s (lpol, kpol) ) * bg (bpol, lpol)
enddo
enddo
enddo
enddo
return
end subroutine s_axis_to_cart
dble ( s (lpol, kpol) ) * bg (bpol, lpol)
ENDDO
ENDDO
ENDDO
ENDDO
RETURN
END SUBROUTINE s_axis_to_cart

458
PP/wannier_ham.f90
View File

@ -3,34 +3,34 @@
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
#define ZERO (0.d0,0.d0)
#define ONE (1.d0,0.d0)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
PROGRAM wannier_ham
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! This program generates Hamiltonian matrix on Wannier-functions basis
use io_global, only: stdout, ionode, ionode_id
use kinds, only: DP
USE io_global, ONLY: stdout, ionode, ionode_id
USE kinds, ONLY: DP
USE io_files, ONLY : prefix, tmp_dir, trimcheck
use wannier_new, only: nwan, use_energy_int
use ktetra
USE wannier_new, ONLY: nwan, use_energy_int
USE ktetra
USE mp, ONLY : mp_bcast
USE read_cards_module, ONLY : read_cards
USE mp_global, ONLY : mp_startup
USE environment, ONLY : environment_start
implicit none
CHARACTER(len=256) :: outdir
integer :: ios
logical :: plot_bands, u_matrix
IMPLICIT NONE
CHARACTER(len=256) :: outdir
INTEGER :: ios
LOGICAL :: plot_bands, u_matrix
real(DP) :: U,J
namelist /inputpp/ outdir, prefix, nwan, plot_bands, use_energy_int, u_matrix
namelist /Umatrix/ U,J
NAMELIST /inputpp/ outdir, prefix, nwan, plot_bands, use_energy_int, u_matrix
NAMELIST /Umatrix/ U,J
! initialise environment
!
#ifdef __PARA
@ -45,11 +45,11 @@ PROGRAM wannier_ham
! set default values for variables in namelist
!
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
IF ( trim( outdir ) == ' ' ) outdir = './'
prefix ='pwscf'
nwan = 0
plot_bands = .FALSE.
u_matrix=.FALSE.
plot_bands = .false.
u_matrix=.false.
!
U=0.d0
J=0.d0
@ -60,57 +60,57 @@ PROGRAM wannier_ham
IF(u_matrix) READ (5, Umatrix, iostat=ios )
!
tmp_dir = trimcheck (outdir)
CALL read_cards('WANNIER_AC')
END IF
ENDIF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios /= 0 ) CALL errore('wannier_ham','reading inputpp namelist',ABS(ios))
call read_file
call openfil_pp
IF ( ios /= 0 ) CALL errore('wannier_ham','reading inputpp namelist',abs(ios))
CALL read_file
CALL openfil_pp
call wannier_init(.FALSE.)
CALL wannier_init(.false.)
call new_hamiltonian(plot_bands)
if(u_matrix) call wannier_u_matrix(U,J)
CALL new_hamiltonian(plot_bands)
IF(u_matrix) CALL wannier_u_matrix(U,J)
CALL stop_pp
CALL wannier_clean()
call stop_pp
call wannier_clean()
END PROGRAM wannier_ham
SUBROUTINE new_hamiltonian(plot_bands)
use io_global, only: stdout, ionode, ionode_id
use io_files
use kinds, only: DP
use wannier_new, only: nwan, pp, wannier_occ, wannier_energy,wan_in
use klist, only: nks, xk, wk
use lsda_mod, only: isk, current_spin, lsda, nspin
use wvfct, only: nbnd, npwx, igk, npw, g2kin, et
use gvect
use cell_base, only: tpiba2
use constants, ONLY : rytoev , tpi
use buffers
USE io_global, ONLY: stdout, ionode, ionode_id
USE io_files
USE kinds, ONLY: DP
USE wannier_new, ONLY: nwan, pp, wannier_occ, wannier_energy,wan_in
USE klist, ONLY: nks, xk, wk
USE lsda_mod, ONLY: isk, current_spin, lsda, nspin
USE wvfct, ONLY: nbnd, npwx, igk, npw, g2kin, et
USE gvect
USE cell_base, ONLY: tpiba2
USE constants, ONLY : rytoev , tpi
USE buffers
USE symm_base, ONLY : nsym
implicit none
logical :: plot_bands
integer :: i,j,k,ik, n, ios, i1, i2, outfile, n_from, n_to
complex(DP) :: wan_func(npwx,nwan), ham(nwan,nwan,nspin), v(nwan,nwan)
complex(DP), allocatable :: hamk(:,:,:), hamh(:,:,:)
real(DP), allocatable :: ek(:,:)
IMPLICIT NONE
LOGICAL :: plot_bands
INTEGER :: i,j,k,ik, n, ios, i1, i2, outfile, n_from, n_to
COMPLEX(DP) :: wan_func(npwx,nwan), ham(nwan,nwan,nspin), v(nwan,nwan)
COMPLEX(DP), ALLOCATABLE :: hamk(:,:,:), hamh(:,:,:)
real(DP), ALLOCATABLE :: ek(:,:)
real(DP) :: e(nwan), x, hoping(3)
! HMLT file unit
outfile = 114
allocate(ek(nwan,nks))
allocate(hamk(nwan,nwan,nks))
allocate(hamh(nwan,nwan,nspin))
ALLOCATE(ek(nwan,nks))
ALLOCATE(hamk(nwan,nwan,nks))
ALLOCATE(hamh(nwan,nwan,nspin))
hamk = ZERO
hamh = ZERO
@ -118,140 +118,140 @@ SUBROUTINE new_hamiltonian(plot_bands)
hoping(2) = 0.
hoping(3) = 0.
ek(:,:) = 0.d0
IF (nsym.GT.1) THEN
write(stdout,'(/5x,a103/)') &
IF (nsym>1) THEN
WRITE(stdout,'(/5x,a103/)') &
'WARNING: k-points set is in the irreducible brillouin zone.',&
' Wannier energies and occupations are wrong!'
END IF
ENDIF
current_spin = 1
call init_us_1
call init_at_1
CALL init_us_1
CALL init_at_1
! Generating igk for orthoatwfc()
REWIND( iunigk )
DO ik = 1, nks
CALL gk_sort( xk(1,ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin )
IF ( nks > 1 ) WRITE( iunigk ) igk
END DO
ENDDO
!
CALL orthoatwfc()
wan_func = ZERO
pp = ZERO
ham = ZERO
do ik = 1, nks
DO ik = 1, nks
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
if (lsda) current_spin = isk(ik)
call wannier_proj(ik,wan_func)
IF (lsda) current_spin = isk(ik)
CALL wannier_proj(ik,wan_func)
pp = ZERO
call get_buffer( pp, nwordwpp, iunwpp, ik)
CALL get_buffer( pp, nwordwpp, iunwpp, ik)
hamk(:,:,ik) = ZERO
do i=1, nwan
do j=1,nwan
n_from = INT (wan_in(i,current_spin)%bands_from )
n_to = INT (wan_in(i,current_spin)%bands_to )
do n = n_from, n_to
DO i=1, nwan
DO j=1,nwan
n_from = int (wan_in(i,current_spin)%bands_from )
n_to = int (wan_in(i,current_spin)%bands_to )
DO n = n_from, n_to
! On-site hamiltonian
ham(i,j,current_spin) = ham(i,j,current_spin) + &
pp(i,n)*CMPLX(et(n,ik),0.d0,KIND=DP)*CONJG(pp(j,n))*wk(ik)
pp(i,n)*cmplx(et(n,ik),0.d0,kind=DP)*conjg(pp(j,n))*wk(ik)
! Hoping integrals
hamh(i,j,current_spin) = hamh(i,j,current_spin) + &
pp(i,n)*CMPLX(et(n,ik),0.d0,KIND=DP)*CONJG(pp(j,n))*wk(ik)*&
pp(i,n)*cmplx(et(n,ik),0.d0,kind=DP)*conjg(pp(j,n))*wk(ik)*&
cdexp( (0.d0,1.d0)*tpi* (xk(1,ik)*hoping(1) + &
xk(2,ik)*hoping(2) + xk(3,ik)*hoping(3)) )
! Current k-point hamiltonian
hamk(i,j,ik) = hamk(i,j,ik) + pp(i,n)*CONJG(pp(j,n))* &
CMPLX(et(n,ik),0.d0,KIND=DP)
hamk(i,j,ik) = hamk(i,j,ik) + pp(i,n)*conjg(pp(j,n))* &
cmplx(et(n,ik),0.d0,kind=DP)
!Overlap mtrx in current k-point (for debug purposes)
end do
end do
end do
ENDDO
ENDDO
ENDDO
IF (plot_bands) CALL cdiagh(nwan,hamk(:,:,ik),nwan,ek(:,ik),v)
if (plot_bands) call cdiagh(nwan,hamk(:,:,ik),nwan,ek(:,ik),v)
!Hermicity check
do i=1,nwan
do j=1,nwan
if(abs(hamk(i,j,ik)-CONJG(hamk(j,i,ik))).ge.1.d-8) then
write(stdout,'(5x,"Wrong elements", 2i3," in",i4," k-point")') i,j,ik
call errore ('wannier_ham', 'Hamiltonian is not hermitian', ik)
end if
end do
end do
end do !ik
!Compute wannier parameters
call wannier_occupancies(wannier_occ)
call wannier_enrg(wannier_energy)
!output computed
do j=1, nspin
write(stdout,'(/5x,a4,i2,a)') 'Spin', j,':'
do i=1, nwan
write(stdout,'(7x,a8,i3)') 'Wannier#',i
write(stdout,'(9x,a11,f5.3)') 'occupation:',wannier_occ(i,i,j)
write(stdout,'(9x,a7,f7.3,a3)') 'energy:',wannier_energy(i,j)*rytoev,' eV'
end do
write(stdout,'(7x,a26/)')'Wannier occupation matrix:'
do i=1,nwan
write(stdout,'(7x,50f7.3)') (wannier_occ(i,k,j),k=1,nwan)
end do
end do
!end of output
! write HMLT file
open (outfile, file = 'hamilt', status = 'unknown', form = 'formatted', err = 300, iostat = ios)
300 call errore ('HMLT', 'Opening hamilt', abs (ios) )
call wannier_hamiltonian_JK(nwan,hamk,outfile)
close(outfile)
DO i=1,nwan
DO j=1,nwan
IF(abs(hamk(i,j,ik)-conjg(hamk(j,i,ik)))>=1.d-8) THEN
WRITE(stdout,'(5x,"Wrong elements", 2i3," in",i4," k-point")') i,j,ik
CALL errore ('wannier_ham', 'Hamiltonian is not hermitian', ik)
ENDIF
ENDDO
ENDDO
ENDDO !ik
if(nspin.eq.1) then
!Compute wannier parameters
CALL wannier_occupancies(wannier_occ)
CALL wannier_enrg(wannier_energy)
!output computed
DO j=1, nspin
WRITE(stdout,'(/5x,a4,i2,a)') 'Spin', j,':'
DO i=1, nwan
WRITE(stdout,'(7x,a8,i3)') 'Wannier#',i
WRITE(stdout,'(9x,a11,f5.3)') 'occupation:',wannier_occ(i,i,j)
WRITE(stdout,'(9x,a7,f7.3,a3)') 'energy:',wannier_energy(i,j)*rytoev,' eV'
ENDDO
WRITE(stdout,'(7x,a26/)')'Wannier occupation matrix:'
DO i=1,nwan
WRITE(stdout,'(7x,50f7.3)') (wannier_occ(i,k,j),k=1,nwan)
ENDDO
ENDDO
!end of output
! write HMLT file
OPEN (outfile, file = 'hamilt', status = 'unknown', form = 'formatted', err = 300, iostat = ios)
300 CALL errore ('HMLT', 'Opening hamilt', abs (ios) )
CALL wannier_hamiltonian_JK(nwan,hamk,outfile)
CLOSE(outfile)
IF(nspin==1) THEN
ham = 5.d-1*ham
hamh = 5.d-1*hamh
end if
ENDIF
do i=1, nspin
write(stdout,*) ' '
DO i=1, nspin
WRITE(stdout,*) ' '
CALL cdiagh(nwan,ham(:,:,i),nwan,e,v)
WRITE(stdout,'(5x,a39)') 'Projected Hamiltonian eigenvalues (eV):'
WRITE(stdout,'(6x,a5,i1,4x,50f9.4)') 'spin', i, (e(j)*rytoev,j=1,nwan)
WRITE(stdout,*) ' '
call cdiagh(nwan,ham(:,:,i),nwan,e,v)
write(stdout,'(5x,a39)') 'Projected Hamiltonian eigenvalues (eV):'
write(stdout,'(6x,a5,i1,4x,50f9.4)') 'spin', i, (e(j)*rytoev,j=1,nwan)
write(stdout,*) ' '
! hopings integrals
if(ANY(hoping.ne.0.d0)) then
write(stdout,'(5x,a44,3f6.2,a5)') 'Hopings from the atom in origin to direction', (hoping(j),j=1,3), 'are:'
do j=1,nwan
write(stdout,'(5x,20f9.5)') (dreal(hamh(j,n,i))*rytoev, n=1, nwan)
end do
write(stdout,*) ' '
end if
IF(any(hoping/=0.d0)) THEN
WRITE(stdout,'(5x,a44,3f6.2,a5)') 'Hopings from the atom in origin to direction', (hoping(j),j=1,3), 'are:'
DO j=1,nwan
WRITE(stdout,'(5x,20f9.5)') (dreal(hamh(j,n,i))*rytoev, n=1, nwan)
ENDDO
WRITE(stdout,*) ' '
ENDIF
! additional check: hamiltonian should be hermitian
if(SUM(dimag(hamh)).ge.1d-9) then
write(stdout,*) 'ATTENTION! Hamiltonian is NOT hermitian'
write(stdout,*) 'Imaginary part is:'
do j=1,nwan
write(stdout,'(20f9.5)') (dimag(hamh(j,n,i))*rytoev, n=1, nwan)
end do
write(stdout,*) '---'
end if
end do
IF(sum(dimag(hamh))>=1d-9) THEN
WRITE(stdout,*) 'ATTENTION! Hamiltonian is NOT hermitian'
WRITE(stdout,*) 'Imaginary part is:'
DO j=1,nwan
WRITE(stdout,'(20f9.5)') (dimag(hamh(j,n,i))*rytoev, n=1, nwan)
ENDDO
WRITE(stdout,*) '---'
ENDIF
ENDDO
if(plot_bands) call plot_wannier_bands(ek)
IF(plot_bands) CALL plot_wannier_bands(ek)
deallocate(ek)
deallocate(hamk)
deallocate(hamh)
DEALLOCATE(ek)
DEALLOCATE(hamk)
DEALLOCATE(hamh)
END SUBROUTINE new_hamiltonian
@ -263,99 +263,99 @@ SUBROUTINE plot_wannier_bands(ek)
! for example 'xmgrace original_bands.dat wannier_bands.dat'
USE constants, ONLY: rytoev
use io_global, only: stdout, ionode, ionode_id
use io_files
use kinds, only: DP
use klist, only: nks, xk
use lsda_mod, only: nspin
use wvfct, only: nbnd, et
use wannier_new, only: nwan
use ener, only: ef
USE io_global, ONLY: stdout, ionode, ionode_id
USE io_files
USE kinds, ONLY: DP
USE klist, ONLY: nks, xk
USE lsda_mod, ONLY: nspin
USE wvfct, ONLY: nbnd, et
USE wannier_new, ONLY: nwan
USE ener, ONLY: ef
IMPLICIT NONE
REAL(DP), INTENT(in) :: ek(nwan,nks)
implicit none
REAL(DP), intent(in) :: ek(nwan,nks)
INTEGER :: i,j,k,ik,ios
REAL(DP) :: x, emax, emin
open (unit = 113, file = 'wannier_bands.dat', status = 'unknown', form = 'formatted', err = 400, iostat = ios)
open (unit = 114, file = 'original_bands.dat', status = 'unknown', form = 'formatted', err = 401, iostat = ios)
open (unit = 115, file = 'wannier_bands.plot', status = 'unknown', form = 'formatted', err = 402, iostat = ios)
400 call errore ('plot_wannier_bands', 'wannier_bands.dat', abs (ios) )
401 call errore ('plot_wannier_bands', 'original_bands.dat', abs (ios) )
402 call errore ('plot_wannier_bands', 'wannier_bands.plot', abs (ios) )
OPEN (unit = 113, file = 'wannier_bands.dat', status = 'unknown', form = 'formatted', err = 400, iostat = ios)
OPEN (unit = 114, file = 'original_bands.dat', status = 'unknown', form = 'formatted', err = 401, iostat = ios)
OPEN (unit = 115, file = 'wannier_bands.plot', status = 'unknown', form = 'formatted', err = 402, iostat = ios)
400 CALL errore ('plot_wannier_bands', 'wannier_bands.dat', abs (ios) )
401 CALL errore ('plot_wannier_bands', 'original_bands.dat', abs (ios) )
402 CALL errore ('plot_wannier_bands', 'wannier_bands.plot', abs (ios) )
emax = ek(1,1)
emin = ek(1,1)
do i=1, nwan
DO i=1, nwan
x = 0.d0
do ik=1, nks/nspin
DO ik=1, nks/nspin
! find limits for pretty plotting
if (emax.lt.ek(i,ik)*rytoev) emax = ek(i,ik)*rytoev
if (emin.gt.ek(i,ik)*rytoev) emin = ek(i,ik)*rytoev
IF (emax<ek(i,ik)*rytoev) emax = ek(i,ik)*rytoev
IF (emin>ek(i,ik)*rytoev) emin = ek(i,ik)*rytoev
!
write(113,'(2f15.9)') x, ek(i,ik)*rytoev
if (ik.ne.nks) then
x = x + SQRT((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
end if
end do
write(113, '(2a)') ' '
end do
do i=1, nbnd
WRITE(113,'(2f15.9)') x, ek(i,ik)*rytoev
IF (ik/=nks) THEN
x = x + sqrt((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
ENDIF
ENDDO
WRITE(113, '(2a)') ' '
ENDDO
DO i=1, nbnd
x = 0.d0
do ik=1, nks/nspin
write(114,'(2f15.9)') x, et(i,ik)*rytoev
if (ik.ne.nks) then
x = x + SQRT((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
end if
end do
write(114, '(2a)') ' '
end do
if (nspin.eq.2) then
do i=1, nwan
x = 0.d0
do ik=nks/2+1, nks
! find limits for pretty plotting
if (emax.lt.ek(i,ik)*rytoev) emax = ek(i,ik)*rytoev
if (emin.gt.ek(i,ik)*rytoev) emin = ek(i,ik)*rytoev
!
write(113,'(2f15.9)') x, ek(i,ik)*rytoev
if (ik.ne.nks) then
x = x + SQRT((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
end if
end do
write(113, '(2a)') ' '
end do
do i=1, nbnd
x = 0.d0
do ik=nks/2+1, nks
write(114,'(2f15.9)') x, et(i,ik)*rytoev
if (ik.ne.nks) then
x = x + SQRT((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
end if
end do
write(114, '(2a)') ' '
end do
end if
write(115,*)'reset'
write(115,*)'set term post eps'
write(115,*)'set output "wannier_bands.eps"'
write(115,*)'unset xtics'
write(115,'(a12,f7.3,a,f7.3,a)')'set yrange [',emin-1.5,':',emax+1.5,']'
write(115,*)'set style line 1 lt 1 lc rgb "black" lw 2'
write(115,*)'set style line 2 lt 2 lc rgb "red" lw 2'
write(115,*)'set style line 3 lt 1 lc rgb "green" lw 1'
write(115,*)'set ylabel "Energy (eV)"'
write(115,*)'plot \\'
write(115,*)'"original_bands.dat" title "LDA bands" with lines linestyle 1,\\'
write(115,*)'"wannier_bands.dat" title "Wannier bands" with lines linestyle 2,\\'
write(115,'(f7.3,a44)') ef*rytoev,'title "Fermi energy" with lines linestyle 3'
DO ik=1, nks/nspin
WRITE(114,'(2f15.9)') x, et(i,ik)*rytoev
IF (ik/=nks) THEN
x = x + sqrt((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
ENDIF
ENDDO
WRITE(114, '(2a)') ' '
ENDDO
IF (nspin==2) THEN
DO i=1, nwan
x = 0.d0
DO ik=nks/2+1, nks
! find limits for pretty plotting
IF (emax<ek(i,ik)*rytoev) emax = ek(i,ik)*rytoev
IF (emin>ek(i,ik)*rytoev) emin = ek(i,ik)*rytoev
!
WRITE(113,'(2f15.9)') x, ek(i,ik)*rytoev
IF (ik/=nks) THEN
x = x + sqrt((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
ENDIF
ENDDO
WRITE(113, '(2a)') ' '
ENDDO
DO i=1, nbnd
x = 0.d0
DO ik=nks/2+1, nks
WRITE(114,'(2f15.9)') x, et(i,ik)*rytoev
IF (ik/=nks) THEN
x = x + sqrt((xk(1,ik)-xk(1,ik+1))**2+(xk(2,ik)-xk(2,ik+1))**2+(xk(3,ik)-xk(3,ik+1))**2)
ENDIF
ENDDO
WRITE(114, '(2a)') ' '
ENDDO
ENDIF
WRITE(115,*)'reset'
WRITE(115,*)'set term post eps'
WRITE(115,*)'set output "wannier_bands.eps"'
WRITE(115,*)'unset xtics'
WRITE(115,'(a12,f7.3,a,f7.3,a)')'set yrange [',emin-1.5,':',emax+1.5,']'
WRITE(115,*)'set style line 1 lt 1 lc rgb "black" lw 2'
WRITE(115,*)'set style line 2 lt 2 lc rgb "red" lw 2'
WRITE(115,*)'set style line 3 lt 1 lc rgb "green" lw 1'
WRITE(115,*)'set ylabel "Energy (eV)"'
WRITE(115,*)'plot \\'
WRITE(115,*)'"original_bands.dat" title "LDA bands" with lines linestyle 1,\\'
WRITE(115,*)'"wannier_bands.dat" title "Wannier bands" with lines linestyle 2,\\'
WRITE(115,'(f7.3,a44)') ef*rytoev,'title "Fermi energy" with lines linestyle 3'
CLOSE(113)
CLOSE(114)
CLOSE(115)
close(113)
close(114)
close(115)
END SUBROUTINE plot_wannier_bands

112
PP/wannier_hamiltonians.f90
View File

@ -7,37 +7,37 @@
#define ZERO (0.d0,0.d0)
#define ONE (1.d0,0.d0)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
SUBROUTINE wannier_hamiltonian_JK(nwan,hamk,outfile)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! for Jan Kunis code
use io_global, only: stdout
use kinds, only: DP
use constants, ONLY : rytoev
use klist, only: nks, wk
USE io_global, ONLY: stdout
USE kinds, ONLY: DP
USE constants, ONLY : rytoev
USE klist, ONLY: nks, wk
implicit none
integer, intent(in) :: nwan, outfile
complex(DP) :: hamk(nwan,nwan,nks)
integer :: i,j, ik
complex(DP), allocatable :: hamk2(:,:)
IMPLICIT NONE
INTEGER, INTENT(in) :: nwan, outfile
COMPLEX(DP) :: hamk(nwan,nwan,nks)
INTEGER :: i,j, ik
COMPLEX(DP), ALLOCATABLE :: hamk2(:,:)
real(DP) :: eps = 1.d-8, hr,hi
write(stdout,'(/5x,a32,i5,a9)') 'Hamiltonian is in the JK format,', nks, 'k-points'
write(stdout,'(5x,a48/)') 'ATTENTION: All k-points weights are real weights'
WRITE(stdout,'(/5x,a32,i5,a9)') 'Hamiltonian is in the JK format,', nks, 'k-points'
WRITE(stdout,'(5x,a48/)') 'ATTENTION: All k-points weights are real weights'
allocate(hamk2(nwan,nwan))
ALLOCATE(hamk2(nwan,nwan))
WRITE(outfile,*) nks,nwan
DO ik = 1, nks
write(outfile,*) nks,nwan
do ik = 1, nks
! if(ik.eq.43) then
! write(stdout,*) 'Omitting point', ik
! CYCLE
! end if
write(outfile,'(f15.12)') wk(ik)
WRITE(outfile,'(f15.12)') wk(ik)
! eg-orbitals should be the first
hamk2 = ZERO
@ -81,18 +81,18 @@ SUBROUTINE wannier_hamiltonian_JK(nwan,hamk,outfile)
hamk2 = hamk2 * rytoev
hamk2 = hamk(:,:,ik) * rytoev
do i=1, nwan
do j=1, nwan
hr = ABS(dreal(hamk2(i,j)))
hi = ABS(aimag(hamk2(i,j)))
if((hr.ge.eps).AND.(hi.ge.eps)) write(outfile,'(2f12.8)') dreal(hamk2(i,j)), aimag(hamk2(i,j))
if ((hr.lt.eps).AND.(hi.ge.eps)) write(outfile,'(f3.0,f12.8)') 0., aimag(hamk2(i,j))
if ((hr.ge.eps).AND.(hi.lt.eps)) write(outfile,'(f12.8,f3.0)') dreal(hamk2(i,j)), 0.
if ((hr.lt.eps).AND.(hi.lt.eps)) write(outfile,'(2f3.0)') 0., 0.
end do
end do
end do
DO i=1, nwan
DO j=1, nwan
hr = abs(dreal(hamk2(i,j)))
hi = abs(aimag(hamk2(i,j)))
IF((hr>=eps).and.(hi>=eps)) WRITE(outfile,'(2f12.8)') dreal(hamk2(i,j)), aimag(hamk2(i,j))
IF ((hr<eps).and.(hi>=eps)) WRITE(outfile,'(f3.0,f12.8)') 0., aimag(hamk2(i,j))
IF ((hr>=eps).and.(hi<eps)) WRITE(outfile,'(f12.8,f3.0)') dreal(hamk2(i,j)), 0.
IF ((hr<eps).and.(hi<eps)) WRITE(outfile,'(2f3.0)') 0., 0.
ENDDO
ENDDO
ENDDO
!for debug
! write(stdout,*) 'Real part of first 5x5 block in Gamma'
@ -105,39 +105,39 @@ SUBROUTINE wannier_hamiltonian_JK(nwan,hamk,outfile)
! end do
!end for debug
deallocate(hamk2)
DEALLOCATE(hamk2)
END SUBROUTINE wannier_hamiltonian_JK
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
SUBROUTINE wannier_hamiltonian_IL(nwan,hamk,outfile)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! Ivan Leonov's code
use io_global, only: stdout
use kinds, only: DP
use constants, ONLY : rytoev
use klist, only: nks
use ktetra
use klist, only: xk, wk
use lsda_mod, only: nspin
implicit none
integer, intent(in) :: nwan, outfile
complex(DP) :: hamk(nwan,nwan,nks)
USE io_global, ONLY: stdout
USE kinds, ONLY: DP
USE constants, ONLY : rytoev
USE klist, ONLY: nks
USE ktetra
USE klist, ONLY: xk, wk
USE lsda_mod, ONLY: nspin
integer :: i,j, ik
IMPLICIT NONE
INTEGER, INTENT(in) :: nwan, outfile
COMPLEX(DP) :: hamk(nwan,nwan,nks)
write(stdout,*) 'Hamiltonian is in the IL format,', nks, 'k-points'
INTEGER :: i,j, ik
write(outfile,*) nks, ntetra
write(outfile,*) nspin, nwan
write(outfile,*) (wk(ik), ik=1,nks)
write(outfile,*) ((xk(i,ik), i=1,3), ik=1,nks)
write(outfile,*) (1, (tetra(i,j), i=1,4), j=1,ntetra)
WRITE(stdout,*) 'Hamiltonian is in the IL format,', nks, 'k-points'
do ik = 1, nks
write(outfile,*) ((dreal(hamk(i,j,ik)),j=i,nwan),i=1,nwan)
write(outfile,*) ((dimag(hamk(i,j,ik)),j=i,nwan),i=1,nwan)
end do
WRITE(outfile,*) nks, ntetra
WRITE(outfile,*) nspin, nwan
WRITE(outfile,*) (wk(ik), ik=1,nks)
WRITE(outfile,*) ((xk(i,ik), i=1,3), ik=1,nks)
WRITE(outfile,*) (1, (tetra(i,j), i=1,4), j=1,ntetra)
DO ik = 1, nks
WRITE(outfile,*) ((dreal(hamk(i,j,ik)),j=i,nwan),i=1,nwan)
WRITE(outfile,*) ((dimag(hamk(i,j,ik)),j=i,nwan),i=1,nwan)
ENDDO
END SUBROUTINE wannier_hamiltonian_IL

316
PP/wannier_plot.f90
View File

@ -3,30 +3,30 @@
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
#define ZERO (0.d0,0.d0)
#define ONE (1.d0,0.d0)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
PROGRAM wannier_plot
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
! This program plots charge density of selected wannier function in
! IBM Data Explorer format
use io_global, only: stdout, ionode, ionode_id
use kinds, ONLY : DP
USE io_global, ONLY: stdout, ionode, ionode_id
USE kinds, ONLY : DP
USE io_files, ONLY : prefix, tmp_dir, trimcheck
use wannier_new, ONLY : nwan, plot_wan_num, plot_wan_spin
USE wannier_new, ONLY : nwan, plot_wan_num, plot_wan_spin
USE mp, ONLY : mp_bcast
USE io_global, ONLY : ionode, stdout
USE mp_global, ONLY : mp_startup
USE environment, ONLY : environment_start
implicit none
CHARACTER(len=256) :: outdir
integer :: ios,nc(3),n0(3)
namelist /inputpp/ outdir, prefix, nwan, plot_wan_num, plot_wan_spin, nc, n0
IMPLICIT NONE
CHARACTER(len=256) :: outdir
INTEGER :: ios,nc(3),n0(3)
NAMELIST /inputpp/ outdir, prefix, nwan, plot_wan_num, plot_wan_spin, nc, n0
!
! initialise environment
!
@ -34,7 +34,7 @@ PROGRAM wannier_plot
CALL mp_startup ( )
#endif
CALL environment_start ( 'WANNIER_PLOT' )
ios = 0
!
IF ( ionode ) THEN
@ -42,11 +42,11 @@ PROGRAM wannier_plot
! set default values for variables in namelist
!
CALL get_env( 'ESPRESSO_TMPDIR', outdir )
IF ( TRIM( outdir ) == ' ' ) outdir = './'
IF ( trim( outdir ) == ' ' ) outdir = './'
prefix ='pwscf'
nwan = 0
plot_wan_spin=1
nc(1) = 3
nc(2) = 3
nc(3) = 3
@ -59,71 +59,71 @@ PROGRAM wannier_plot
READ (5, inputpp, iostat=ios )
!
tmp_dir = trimcheck (outdir)
END IF
ENDIF
!
CALL mp_bcast( ios, ionode_id )
IF ( ios /= 0 ) CALL errore('wannier_ham','reading inputpp namelist',ABS(ios))
call read_file
call openfil_pp
IF ( ios /= 0 ) CALL errore('wannier_ham','reading inputpp namelist',abs(ios))
CALL read_file
CALL openfil_pp
call wannier_init(.true.)
CALL wannier_init(.true.)
!debug
write(stdout,'(5x,"Calling plot_wannier for wannier",i3)') plot_wan_num
WRITE(stdout,'(5x,"Calling plot_wannier for wannier",i3)') plot_wan_num
!end of debug
call plot_wannier(nc,n0)
CALL plot_wannier(nc,n0)
!debug
write(stdout,'(5x,"Calling plot_atoms")')
WRITE(stdout,'(5x,"Calling plot_atoms")')
!end of debug
call plot_atoms()
call stop_pp
call wannier_clean()
CALL plot_atoms()
CALL stop_pp
CALL wannier_clean()
END PROGRAM wannier_plot
SUBROUTINE plot_wannier(nc,n0)
use io_global, only: stdout, ionode, ionode_id
use io_files
use kinds, only: DP
use wannier_new, only: nwan,plot_wan_num,plot_wan_spin
use klist, only: nks, xk, wk
use lsda_mod, only: isk, current_spin, lsda, nspin
use wvfct, only: nbnd, npwx, igk, npw, g2kin
use constants, ONLY : rytoev , tpi
use buffers
USE io_global, ONLY: stdout, ionode, ionode_id
USE io_files
USE kinds, ONLY: DP
USE wannier_new, ONLY: nwan,plot_wan_num,plot_wan_spin
USE klist, ONLY: nks, xk, wk
USE lsda_mod, ONLY: isk, current_spin, lsda, nspin
USE wvfct, ONLY: nbnd, npwx, igk, npw, g2kin
USE constants, ONLY : rytoev , tpi
USE buffers
USE symm_base, ONLY : nsym
USE ldaU, ONLY : swfcatom
use gvect
use gsmooth
use cell_base
USE gvect
USE gsmooth
USE cell_base
USE ions_base, ONLY : nat, ntyp=>nsp, ityp, tau, atm, zv
USE vlocal, ONLY : strf
implicit none
integer, intent(in) :: nc(3), n0(3)
integer :: i,j, k, ik, n, ir, ios, n1, n2, n3,i1,j1,k1
IMPLICIT NONE
INTEGER, INTENT(in) :: nc(3), n0(3)
INTEGER :: i,j, k, ik, n, ir, ios, n1, n2, n3,i1,j1,k1
COMPLEX(DP) :: phase
COMPLEX(DP), allocatable :: wan_func(:,:), pp_ort(:,:), psic(:), psic3(:,:,:), psic3_0(:,:,:), psic_sum(:,:,:,:), paux(:,:)
real(DP), allocatable :: rho(:,:,:,:), raux(:)
COMPLEX(DP), ALLOCATABLE :: wan_func(:,:), pp_ort(:,:), psic(:), psic3(:,:,:), psic3_0(:,:,:), psic_sum(:,:,:,:), paux(:,:)
real(DP), ALLOCATABLE :: rho(:,:,:,:), raux(:)
real(DP) :: r(3)
IF (nsym.GT.1) THEN
call errore('wannier_cmptn','k-points set is in the irreducible brillouin zone - not implemented',1)
END IF
allocate(wan_func(npwx,nwan))
allocate(psic(nrxxs))
allocate(psic3(nrx1s,nrx2s,nrx3s))
allocate(psic3_0(nrx1s,nrx2s,nrx3s))
allocate(psic_sum(nc(1)*nrx1s,nc(2)*nrx2s,nc(3)*nrx3s,nspin))
allocate(rho(nc(1)*nrx1s,nc(2)*nrx2s,nc(3)*nrx3s,nspin))
IF (nsym>1) THEN
CALL errore('wannier_cmptn','k-points set is in the irreducible brillouin zone - not implemented',1)
ENDIF
call init_us_1
call init_at_1
ALLOCATE(wan_func(npwx,nwan))
ALLOCATE(psic(nrxxs))
ALLOCATE(psic3(nrx1s,nrx2s,nrx3s))
ALLOCATE(psic3_0(nrx1s,nrx2s,nrx3s))
ALLOCATE(psic_sum(nc(1)*nrx1s,nc(2)*nrx2s,nc(3)*nrx3s,nspin))
ALLOCATE(rho(nc(1)*nrx1s,nc(2)*nrx2s,nc(3)*nrx3s,nspin))
CALL init_us_1
CALL init_at_1
CALL struc_fact (nat, tau, ntyp, ityp, ngm, g, bg, nr1, nr2, nr3, &
strf, eigts1, eigts2, eigts3)
@ -134,133 +134,133 @@ SUBROUTINE plot_wannier(nc,n0)
psic3_0 = ZERO
psic_sum = ZERO
do ik = 1, nks
DO ik = 1, nks
CALL gk_sort (xk (1, ik), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin)
if (lsda) current_spin = isk(ik)
IF (lsda) current_spin = isk(ik)
wan_func = ZERO
call get_buffer( wan_func, nwordwf, iunwf, ik)
CALL get_buffer( wan_func, nwordwf, iunwf, ik)
psic(1:nrxxs) = ZERO
rho = ZERO
do j = 1, npw
DO j = 1, npw
psic (nls (igk (j) ) ) = wan_func (j, plot_wan_num)
end do
call cft3s (psic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
do k=1, nrx3s
do j=1,nrx2s
do i=1,nrx1s
ENDDO
CALL cft3s (psic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, 2)
DO k=1, nrx3s
DO j=1,nrx2s
DO i=1,nrx1s
n = i + (j-1)*nrx1s + (k-1)*nrx2s*nrx1s
psic3_0(i,j,k) = psic(n)
end do
end do
end do
do k=1, (nrx3s-1)*nc(3)
do j=1, (nrx2s-1)*nc(2)
do i=1, (nrx1s-1)*nc(1)
ENDDO
ENDDO
ENDDO
DO k=1, (nrx3s-1)*nc(3)
DO j=1, (nrx2s-1)*nc(2)
DO i=1, (nrx1s-1)*nc(1)
! r = n0(1)*at(1,:)+n0(2)*at(2,:)+n0(3)*at(3,:)
! r = r + DBLE(i-1)*at(1,:)/DBLE(nrx1s-1)+DBLE(j-1)*at(2,:)/DBLE(nrx2s-1)+DBLE(k-1)*at(3,:)/DBLE(nrx3s-1)
r = n0(1)*at(:,1)+n0(2)*at(:,2)+n0(3)*at(:,3)
r = r + DBLE(i-1)*at(:,1)/DBLE(nrx1s-1) + &
DBLE(j-1)*at(:,2)/DBLE(nrx2s-1) + &
DBLE(k-1)*at(:,3)/DBLE(nrx3s-1)
r = r + dble(i-1)*at(:,1)/dble(nrx1s-1) + &
dble(j-1)*at(:,2)/dble(nrx2s-1) + &
dble(k-1)*at(:,3)/dble(nrx3s-1)
phase = cos(tpi*(xk(1,ik)*r(1)+xk(2,ik)*r(2)+xk(3,ik)*r(3))) + &
(0.d0,1.d0)*sin(tpi*(xk(1,ik)*r(1)+xk(2,ik)*r(2)+xk(3,ik)*r(3)))
i1 = i - FLOOR(DBLE(i-0.01)/DBLE(nrx1s-1))*(nrx1s-1)
j1 = j - FLOOR(DBLE(j-0.01)/DBLE(nrx2s-1))*(nrx2s-1)
k1 = k - FLOOR(DBLE(k-0.01)/DBLE(nrx3s-1))*(nrx3s-1)
i1 = i - floor(dble(i-0.01)/dble(nrx1s-1))*(nrx1s-1)
j1 = j - floor(dble(j-0.01)/dble(nrx2s-1))*(nrx2s-1)
k1 = k - floor(dble(k-0.01)/dble(nrx3s-1))*(nrx3s-1)
psic_sum(i,j,k,current_spin) = psic_sum(i,j,k,current_spin)+ &
CMPLX(wk(ik),0.d0,KIND=DP)*psic3_0(i1,j1,k1)*phase
end do
end do
end do
end do !ik
cmplx(wk(ik),0.d0,kind=DP)*psic3_0(i1,j1,k1)*phase
ENDDO
ENDDO
ENDDO
ENDDO !ik
rho = 0.d0
do n=1, nspin
do i=1, nrx1s*nc(1)
do j=1, nrx2s*nc(2)
do k=1,nrx3s*nc(3)
DO n=1, nspin
DO i=1, nrx1s*nc(1)
DO j=1, nrx2s*nc(2)
DO k=1,nrx3s*nc(3)
rho(i,j,k,n) = dreal(psic_sum(i,j,k,n))**2+aimag(psic_sum(i,j,k,n))**2
end do
end do
end do
end do
open (10, file='wannier.plot.dx', err = 100, iostat = ios)
100 call errore ('plot_wannier', 'Opening out file', abs (ios) )
ENDDO
ENDDO
ENDDO
ENDDO
OPEN (10, file='wannier.plot.dx', err = 100, iostat = ios)
100 CALL errore ('plot_wannier', 'Opening out file', abs (ios) )
! I want to write .dx file for dataexplorer
write(10,'(a36,3i6)') 'object 1 class gridpositions counts ', nrx3s*nc(3), nrx2s*nc(2), nrx1s*nc(1)
write(10,*) 'origin', n0(1)*at(:,1)+n0(2)*at(:,2)+n0(3)*at(:,3)
WRITE(10,'(a36,3i6)') 'object 1 class gridpositions counts ', nrx3s*nc(3), nrx2s*nc(2), nrx1s*nc(1)
WRITE(10,*) 'origin', n0(1)*at(:,1)+n0(2)*at(:,2)+n0(3)*at(:,3)
! write(10,'(a5, 3f9.5)') 'delta', (at(3,i)/(1.d0*(nrx3s-1)),i=1,3)
! write(10,'(a5, 3f9.5)') 'delta', (at(2,i)/(1.d0*(nrx2s-1)),i=1,3)
! write(10,'(a5, 3f9.5)') 'delta', (at(1,i)/(1.d0*(nrx1s-1)),i=1,3)
write(10,'(a5, 3f9.5)') 'delta', (at(i,1)/(1.d0*(nrx3s-1)),i=1,3)
write(10,'(a5, 3f9.5)') 'delta', (at(i,2)/(1.d0*(nrx2s-1)),i=1,3)
write(10,'(a5, 3f9.5)') 'delta', (at(i,3)/(1.d0*(nrx1s-1)),i=1,3)
write(10,'(a38,3i6)') 'object 2 class gridconnections counts ', nrx3s*nc(3), nrx2s*nc(2), nrx1s*nc(1)
write(10,*) 'attribute "element type" string "cubes"'
write(10,*) 'attribute "ref" string "positions"'
write(10,'(a44,i10,a13)') 'object 3 class array type float rank 0 items', nrx3s*nc(3)*nrx2s*nc(2)*nrx1s*nc(1), 'data follows'
do i=1, nrx3s*nc(3)
do j=1,nrx2s*nc(2)
do k=1,nrx1s*nc(1)
write(10,'(f13.7)') rho(k,j,i,plot_wan_spin)
! write(10,'(f13.7)') aimag(psic_sum(k,j,i,plot_wan_spin))
end do
end do
end do
WRITE(10,'(a5, 3f9.5)') 'delta', (at(i,1)/(1.d0*(nrx3s-1)),i=1,3)
WRITE(10,'(a5, 3f9.5)') 'delta', (at(i,2)/(1.d0*(nrx2s-1)),i=1,3)
WRITE(10,'(a5, 3f9.5)') 'delta', (at(i,3)/(1.d0*(nrx1s-1)),i=1,3)
WRITE(10,'(a38,3i6)') 'object 2 class gridconnections counts ', nrx3s*nc(3), nrx2s*nc(2), nrx1s*nc(1)
WRITE(10,*) 'attribute "element type" string "cubes"'
WRITE(10,*) 'attribute "ref" string "positions"'
WRITE(10,'(a44,i10,a13)') 'object 3 class array type float rank 0 items', nrx3s*nc(3)*nrx2s*nc(2)*nrx1s*nc(1), 'data follows'
write(10,'(a34)') 'attribute "dep" string "positions"'
write(10,*) 'object "regular positions regular connections" class field'
write(10,*) 'component "positions" value 1'
write(10,*) 'component "connections" value 2'
write(10,*) 'component "data" value 3'
write(10,*) 'end'
close(10)
deallocate(wan_func)
deallocate(psic)
deallocate(psic3)
deallocate(psic3_0)
deallocate(psic_sum)
deallocate(rho)
DO i=1, nrx3s*nc(3)
DO j=1,nrx2s*nc(2)
DO k=1,nrx1s*nc(1)
WRITE(10,'(f13.7)') rho(k,j,i,plot_wan_spin)
! write(10,'(f13.7)') aimag(psic_sum(k,j,i,plot_wan_spin))
ENDDO
ENDDO
ENDDO
WRITE(10,'(a34)') 'attribute "dep" string "positions"'
WRITE(10,*) 'object "regular positions regular connections" class field'
WRITE(10,*) 'component "positions" value 1'
WRITE(10,*) 'component "connections" value 2'
WRITE(10,*) 'component "data" value 3'
WRITE(10,*) 'end'
CLOSE(10)
DEALLOCATE(wan_func)
DEALLOCATE(psic)
DEALLOCATE(psic3)
DEALLOCATE(psic3_0)
DEALLOCATE(psic_sum)
DEALLOCATE(rho)
END SUBROUTINE plot_wannier
SUBROUTINE plot_atoms
use io_global, only: stdout
use kinds, only: DP
use ions_base, only: tau, nat, ityp, zv
implicit none
integer :: i,na, ios
open (20, file='atoms.plot.dx', err = 200, iostat = ios)
200 call errore ('plot_wannier', 'Opening out atoms file', abs (ios) )
write(20,*) 'object 1 class array type float rank 1 shape 3 items', nat,' data follows'
do na = 1, nat
write(20,'(3f9.5)') (tau(i,na),i=1,3)
enddo
write(20,*) 'object 2 class array type float rank 0 items', nat,' data follows'
do na = 1, nat
write(20,*) zv(ityp(na))
enddo
write(20,*) 'attribute "dep" string "positions"'
write(20,*) 'object "irregular positions" class field'
write(20,*) 'component "positions" value 1'
write(20,*) 'component "data" value 2'
write(20,*) 'end'
close(20)
USE io_global, ONLY: stdout
USE kinds, ONLY: DP
USE ions_base, ONLY: tau, nat, ityp, zv
IMPLICIT NONE
INTEGER :: i,na, ios
OPEN (20, file='atoms.plot.dx', err = 200, iostat = ios)
200 CALL errore ('plot_wannier', 'Opening out atoms file', abs (ios) )
WRITE(20,*) 'object 1 class array type float rank 1 shape 3 items', nat,' data follows'
DO na = 1, nat
WRITE(20,'(3f9.5)') (tau(i,na),i=1,3)
ENDDO
WRITE(20,*) 'object 2 class array type float rank 0 items', nat,' data follows'
DO na = 1, nat
WRITE(20,*) zv(ityp(na))
ENDDO
WRITE(20,*) 'attribute "dep" string "positions"'
WRITE(20,*) 'object "irregular positions" class field'
WRITE(20,*) 'component "positions" value 1'
WRITE(20,*) 'component "data" value 2'
WRITE(20,*) 'end'
CLOSE(20)
END SUBROUTINE plot_atoms

126
PP/wannier_u_matrix.f90
View File

@ -6,85 +6,85 @@
!
SUBROUTINE wannier_u_matrix(U,hJ)
use io_global, only: stdout, ionode, ionode_id
use io_files
use kinds, only: DP
use wannier_new, only: nwan, pp, wannier_occ, wannier_energy,wan_in
implicit none
integer i,j, k,c, iwan, l
USE io_global, ONLY: stdout, ionode, ionode_id
USE io_files
USE kinds, ONLY: DP
USE wannier_new, ONLY: nwan, pp, wannier_occ, wannier_energy,wan_in
IMPLICIT NONE
INTEGER i,j, k,c, iwan, l
real(DP) :: U, hJ, u2(10,10)
integer :: atoms(10)
INTEGER :: atoms(10)
real(DP) :: rotm(10,10), unew(10,10), tmp
write(stdout,'(5x,a34)') 'Generation of interaction matrix U'
write(stdout,'(5x,a29)') '(works only for nspin=1 case)'
write(stdout,*)
WRITE(stdout,'(5x,a34)') 'Generation of interaction matrix U'
WRITE(stdout,'(5x,a29)') '(works only for nspin=1 case)'
WRITE(stdout,*)
u2 = 0.d0
call mk_u(2,5,U,hJ,u2)
CALL mk_u(2,5,U,hJ,u2)
!rotation from TB-LMTO basis to our new
rotm = 0.d0
c = 0
do iwan=1, nwan
do j=1,wan_in(iwan,1)%ning
if(wan_in(iwan,1)%ing(j)%l.eq.2) then
DO iwan=1, nwan
DO j=1,wan_in(iwan,1)%ning
IF(wan_in(iwan,1)%ing(j)%l==2) THEN
c = c+1
SELECT CASE(wan_in(iwan,1)%ing(j)%m)
CASE(1)
CASE(1)
rotm(c,3) = wan_in(iwan,1)%ing(j)%c
CASE(2)
CASE(2)
rotm(c,4) = wan_in(iwan,1)%ing(j)%c
CASE(3)
CASE(3)
rotm(c,2) = wan_in(iwan,1)%ing(j)%c
CASE(4)
CASE(4)
rotm(c,5) = wan_in(iwan,1)%ing(j)%c
CASE(5)
CASE(5)
rotm(c,1) = wan_in(iwan,1)%ing(j)%c
END SELECT
end if
end do
end do
if(c.gt.5) call errore('Too many interactiong atoms - cant construct U matrix',c)
do i=1,5
do j=1,5
ENDIF
ENDDO
ENDDO
IF(c>5) CALL errore('Too many interactiong atoms - cant construct U matrix',c)
DO i=1,5
DO j=1,5
rotm(i+5,j+5) = rotm(i,j)
end do
end do
do i = 1,10
do j = 1, 10
ENDDO
ENDDO
DO i = 1,10
DO j = 1, 10
tmp = 0.d0
do k=1,10
do l=1,10
DO k=1,10
DO l=1,10
tmp=tmp+rotm(i,k)*u2(k,l)*rotm(j,l)
enddo
enddo
unew(i,j)=tmp
enddo
enddo
!output
do i=1,c
write(stdout,'(5x,10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
end do
do i=6,5+c
write(stdout,'(5x,10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
end do
write(stdout,*)
open(70,file='umatrix',status='unknown',form='formatted')
do i=1,c
write(70,'(10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
end do
do i=6,5+c
write(70,'(10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
end do
write(70,*)
close(70)
ENDDO
ENDDO
unew(i,j)=tmp
ENDDO
ENDDO
!output
DO i=1,c
WRITE(stdout,'(5x,10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
ENDDO
DO i=6,5+c
WRITE(stdout,'(5x,10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
ENDDO
WRITE(stdout,*)
OPEN(70,file='umatrix',status='unknown',form='formatted')
DO i=1,c
WRITE(70,'(10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
ENDDO
DO i=6,5+c
WRITE(70,'(10f5.2)') (unew(i,j),j=1,c), (unew(i,j+5),j=1,c)
ENDDO
WRITE(70,*)
CLOSE(70)
END SUBROUTINE wannier_u_matrix

44
PP/wannier_umatrix_subroutines.f90
View File

@ -19,9 +19,9 @@ SUBROUTINE mk_u(l,mmax,uvalue,jvalue,u2)
CALL rcl_init(l,uvalue,jvalue,rcl)
xu = rcl(1)
xj = 0.d0
IF(l.eq.1) xj = rcl(2)/5.d0
IF(l.eq.2) xj = (rcl(2)+rcl(3))/14.d0
IF(l.eq.3) xj = (4.d0*rcl(2)/15.d0+2.d0*rcl(3)/11.d0+100.d0*rcl(4)/429.d0 )/6.d0
IF(l==1) xj = rcl(2)/5.d0
IF(l==2) xj = (rcl(2)+rcl(3))/14.d0
IF(l==3) xj = (4.d0*rcl(2)/15.d0+2.d0*rcl(3)/11.d0+100.d0*rcl(4)/429.d0 )/6.d0
! Produce 4index Coulomb interaction matrix
CALL u4ind(u,rcl,l)
DO i = 1, mmax
@ -70,7 +70,7 @@ SUBROUTINE u4ind(u,rcl,l)
xm3 = dfloat(ms3-l-1)
xm = xm1 - xm3
DO ms4 = 1,mmax
IF ((ms1+ms2-ms3-ms4).ne.0) CYCLE
IF ((ms1+ms2-ms3-ms4)/=0) CYCLE
xm4 = dfloat(ms4-l-1)
cgk1 = cgk(xl,xm3,xk,xm,xl,xm1)
cgk2 = cgk(xl,xm2,xk,xm,xl,xm4)
@ -103,16 +103,16 @@ SUBROUTINE u4ind(u,rcl,l)
DO ms4=1,mmax
DO ms5=1,mmax
am1 = dcmplx(yor(ms1,ms5),-yoi(ms1,ms5))
IF (am1.eq.amz) CYCLE
IF (am1==amz) CYCLE
DO ms6=1,mmax
am2 = dcmplx(yor(ms2,ms6),-yoi(ms2,ms6))
IF (am2.eq.amz) CYCLE
IF (am2==amz) CYCLE
DO ms7=1,mmax
am3 = dcmplx(yor(ms3,ms7),yoi(ms3,ms7))
IF (am3.eq.amz) CYCLE
IF (am3==amz) CYCLE
DO ms8=1,mmax
am4 = dcmplx(yor(ms4,ms8),yoi(ms4,ms8))
IF (am4.eq.amz) CYCLE
IF (am4==amz) CYCLE
u(ms1,ms2,ms3,ms4) = u(ms1,ms2,ms3,ms4) &
+ am1*am2*am3*am4*uc(ms5,ms6,ms7,ms8)
ENDDO
@ -156,11 +156,11 @@ DOUBLE PRECISION FUNCTION cgk(a,al,b,be,c,ga)
zmin=max0(i1,-i5,-i6)
zmax=min0(i2, i3, i4)
cgk=0.d0
IF (dabs(al).gt.a) RETURN
IF (dabs(be).gt.b) RETURN
IF (dabs(ga).gt.c) RETURN
IF ( zmin.gt.zmax ) RETURN
IF ( (al+be).ne.ga ) RETURN
IF (dabs(al)>a) RETURN
IF (dabs(be)>b) RETURN
IF (dabs(ga)>c) RETURN
IF ( zmin>zmax ) RETURN
IF ( (al+be)/=ga ) RETURN
i7=idint(a-b+c)
i8=idint(c+b-a)
i9=idint(c+b+a)
@ -192,15 +192,15 @@ SUBROUTINE ctormt(yor,yoi,l)
CALL dinit(yor,7*7)
CALL dinit(yoi,7*7)
sqtwo=1.d0/dsqrt(2.d0)
IF (l.eq.0) THEN
IF (l==0) THEN
yor(1,1)=1.d0
ELSEIF (l.eq.1) THEN
ELSEIF (l==1) THEN
yoi(1,1)= sqtwo
yoi(1,3)= sqtwo
yor(2,2)=1.d0
yor(3,1)= sqtwo
yor(3,3)=-sqtwo
ELSEIF (l.eq.2) THEN
ELSEIF (l==2) THEN
yoi(1,1)= sqtwo
yoi(1,5)=-sqtwo
yoi(2,2)= sqtwo
@ -210,7 +210,7 @@ SUBROUTINE ctormt(yor,yoi,l)
yor(4,4)=-sqtwo
yor(5,1)= sqtwo
yor(5,5)= sqtwo
ELSEIF (l.eq.3) THEN
ELSEIF (l==3) THEN
yoi(1,1)= sqtwo
yoi(1,7)= sqtwo
yoi(2,2)= sqtwo
@ -245,12 +245,12 @@ SUBROUTINE rcl_init(l,uvalue,jvalue,rcl)
uv = uvalue
jv = jvalue
rcl(1) = uv
IF(l .eq. 1) THEN
IF(l == 1) THEN
rcl(2) = jv *5.d0
ELSEIF(l .eq. 2) THEN
ELSEIF(l == 2) THEN
rcl(2) = jv * 14d0 / (1.d0 + 0.63d0)
rcl(3) = 0.63d0 * rcl(2)
ELSEIF(l .eq. 3) THEN
ELSEIF(l == 3) THEN
rcl(2) = 6435.d0 * jv / (286.d0 + 195.d0 * &
451.d0 / 675.d0 + 250.d0 * 1001.d0 / 2025.d0)
rcl(3) = 451.d0 * rcl(2) / 675.d0
@ -268,11 +268,11 @@ SUBROUTINE dinit(array,leng)
INTEGER i,m,mp1
m = mod(leng,5)
IF( m .ne. 0 ) THEN
IF( m /= 0 ) THEN
DO i = 1,m
array(i) = 0.d0
ENDDO
IF( leng .lt. 5 ) RETURN
IF( leng < 5 ) RETURN
ENDIF
mp1 = m + 1
DO i = mp1,leng,5

786
PP/wfdd.f90
View File

File diff suppressed because it is too large Load Diff

40
PP/work_function.f90
View File

@ -30,12 +30,12 @@ SUBROUTINE work_function (wf)
REAL(DP), ALLOCATABLE :: vxc(:,:)
! auxiliary vectors for charge and potential
ALLOCATE (raux1( nrx1 * nrx2 * nrx3))
ALLOCATE (vaux1( nrx1 * nrx2 * nrx3))
ALLOCATE (vaux2( nrx1 * nrx2 * nrx3))
ALLOCATE (raux1( nrx1 * nrx2 * nrx3))
ALLOCATE (vaux1( nrx1 * nrx2 * nrx3))
ALLOCATE (vaux2( nrx1 * nrx2 * nrx3))
nspin0=nspin
if (nspin==4) nspin0=1
IF (nspin==4) nspin0=1
ALLOCATE (vxc(nrxx,nspin))
CALL v_xc (rho, rho_core, rhog_core, etxc, vtxc, vxc)
@ -45,14 +45,14 @@ SUBROUTINE work_function (wf)
CALL seqopn (17, 'workf', 'formatted', exst)
CALL seqopn (19, 'charge', 'formatted', exst)
!
END IF
ENDIF
wf = 0.d0
DO current_spin=1,nspin0
#ifdef __PARA
ALLOCATE (aux ( nrxx))
ALLOCATE (aux ( nrxx))
aux(:) = rho%of_r(:,current_spin) + rho_core(:)/nspin0
CALL grid_gather (aux, raux1)
#else
@ -75,13 +75,13 @@ SUBROUTINE work_function (wf)
IF ( ionode ) THEN
!
IF (nspin == 2) THEN
IF (current_spin.EQ.1) THEN
IF (current_spin==1) THEN
WRITE(17,*) " SPIN UP "
WRITE(19,*) " SPIN UP "
ELSE
WRITE(17,*) " SPIN DOWN "
WRITE(19,*) " SPIN DOWN "
END IF
ENDIF
ENDIF
DO nmean = 1, nr3
wmean1 = 0.d0
@ -97,28 +97,28 @@ SUBROUTINE work_function (wf)
wxm = wxm + raux1 (ni) **2
wmean1 = wmean1 + vaux1 (ni)
wx1 = wx1 + vaux1 (ni) **2
wmean2 = wmean2 + vaux2 (ni)
wmean2 = wmean2 + vaux2 (ni)
wx2 = wx2 + vaux2 (ni) **2
ENDDO
ENDDO
wmean1 = wmean1 / DBLE (nr1 * nr2)
wmean2 = wmean2 / DBLE (nr1 * nr2)
meancharge = meancharge / DBLE (nr1 * nr2)
wx1 = dsqrt (wx1 / DBLE (nr1 * nr2) - wmean1 * wmean1)
wx2 = dsqrt (wx2 / DBLE (nr1 * nr2) - wmean2 * wmean2)
wxm = dsqrt (wxm / DBLE (nr1 * nr2) - meancharge**2)
IF (nmean.EQ. (nr3 + 1) / 2) THEN
wmean1 = wmean1 / dble (nr1 * nr2)
wmean2 = wmean2 / dble (nr1 * nr2)
meancharge = meancharge / dble (nr1 * nr2)
wx1 = dsqrt (wx1 / dble (nr1 * nr2) - wmean1 * wmean1)
wx2 = dsqrt (wx2 / dble (nr1 * nr2) - wmean2 * wmean2)
wxm = dsqrt (wxm / dble (nr1 * nr2) - meancharge**2)
IF (nmean== (nr3 + 1) / 2) THEN
wf = wf + (wmean2 - ef)
IF (nspin == 2) THEN
IF (current_spin.EQ.1) THEN
IF (current_spin==1) THEN
WRITE( stdout,*) " SPIN UP "
ELSE
WRITE( stdout,*) " SPIN DOWN "
END IF
ENDIF
ENDIF
WRITE( stdout, 9130) rytoev * (wmean1 - ef), wx1 * rytoev, &
rytoev * (wmean2 - ef), wx2 * rytoev
END IF
ENDIF
WRITE (17, * ) nmean, (wmean1 - ef) * rytoev, wx1 * rytoev, &
(wmean2 - ef) * rytoev, wx2 * rytoev
WRITE (19, * ) nmean, meancharge, wxm
@ -126,7 +126,7 @@ SUBROUTINE work_function (wf)
!
ENDIF
!
END DO
ENDDO
wf = wf / nspin0
!
CALL mp_bcast( wf, ionode_id )

74
PP/write_p_avg.f90
View File

@ -36,50 +36,50 @@ SUBROUTINE write_p_avg(filp, spin_component, firstk, lastk)
INTEGER :: spin_component, nks1, nks2, firstk, lastk
INTEGER :: iunout, ios, ik, ibnd, jbnd, ipol, nbnd_occ
COMPLEX(DP) :: zdotc
COMPLEX(DP), ALLOCATABLE :: ppsi(:,:), ppsi_us(:,:), matp(:,:,:)
CHARACTER (LEN=256) :: filp, namefile
COMPLEX(DP), ALLOCATABLE :: ppsi(:,:), ppsi_us(:,:), matp(:,:,:)
CHARACTER (len=256) :: filp, namefile
!
IF (lda_plus_u) CALL errore('write_p_avg', &
'write_p_avg not working with LDA+U',1)
ALLOCATE(matp(nbnd,nbnd,3))
CALL allocate_bec_type ( nkb, nbnd, becp)
IF (nspin==1.OR.nspin==4) THEN
nks1=MAX(1,firstk)
nks2=MIN(nkstot, lastk)
IF (spin_component .ne. 1) &
IF (nspin==1.or.nspin==4) THEN
nks1=max(1,firstk)
nks2=min(nkstot, lastk)
IF (spin_component /= 1) &
CALL errore('write_p_avg','incorrect spin_component',1)
ELSE IF (nspin.eq.2) THEN
ELSEIF (nspin==2) THEN
IF (spin_component == 1) THEN
nks1=MAX(1,firstk)
nks2=MIN(nks/2,lastk)
ELSE IF (spin_component==2) THEN
nks1=nks/2 + MAX(1,firstk)
nks2=nks/2 + MIN(nks/2,lastk)
nks1=max(1,firstk)
nks2=min(nks/2,lastk)
ELSEIF (spin_component==2) THEN
nks1=nks/2 + max(1,firstk)
nks2=nks/2 + min(nks/2,lastk)
ELSE
CALL errore('write_p_avg','incorrect spin_component',1)
END IF
END IF
ENDIF
ENDIF
ios = 0
IF ( ionode ) THEN
iunout=58
namefile=TRIM(filp)
namefile=trim(filp)
OPEN (unit = iunout, file = namefile, status = 'unknown', form = &
'formatted', iostat = ios)
REWIND (iunout)
END IF
ENDIF
CALL mp_bcast (ios, ionode_id)
IF ( ios/=0 ) CALL errore ('write_p_avg', 'Opening filband file', ABS (ios) )
IF ( ios/=0 ) CALL errore ('write_p_avg', 'Opening filband file', abs (ios) )
DO ik = nks1, nks2
!
! Compute the number of occupated bands at this k point
!
DO ibnd = 1, nbnd
IF (et (ibnd, ik).LE.ef) nbnd_occ = ibnd
END DO
IF (et (ibnd, ik)<=ef) nbnd_occ = ibnd
ENDDO
IF (nbnd_occ==nbnd) WRITE( stdout, '(5x,/,&
&"No empty band at point ", i4,3f10.5)') &
ik, (xk (ipol, ik) , ipol = 1, 3)
@ -102,21 +102,21 @@ SUBROUTINE write_p_avg(filp, spin_component, firstk, lastk)
CALL calbec ( npw, vkb, evc, becp, nbnd_occ )
ELSE
CALL calbec ( npw, vkb, evc, becp, nbnd_occ )
END IF
ENDIF
DO ipol=1,3
CALL compute_ppsi(ppsi, ppsi_us, ik, ipol, nbnd_occ, spin_component)
DO ibnd=nbnd_occ+1,nbnd
DO jbnd=1,nbnd_occ
IF (noncolin) THEN
matp(ibnd-nbnd_occ,jbnd,ipol)= &
zdotc(npwx*npol,evc(1,ibnd),1,ppsi(1,jbnd),1)
zdotc(npwx*npol,evc(1,ibnd),1,ppsi(1,jbnd),1)
IF (okvan) THEN
matp(ibnd-nbnd_occ,jbnd,ipol)= &
matp(ibnd-nbnd_occ,jbnd,ipol)+ &
(0.d0,0.5d0)*(et(ibnd,ik)-et(jbnd,ik))* &
(zdotc(npwx*npol,evc(1,ibnd),1,ppsi_us(1,jbnd),1) )
END IF
ENDIF
ELSE
matp(ibnd-nbnd_occ,jbnd,ipol)= &
zdotc(npw,evc(1,ibnd),1,ppsi(1,jbnd),1)
@ -124,13 +124,13 @@ SUBROUTINE write_p_avg(filp, spin_component, firstk, lastk)
matp(ibnd-nbnd_occ,jbnd,ipol)= &
matp(ibnd-nbnd_occ,jbnd,ipol) + &
(0.d0,0.5d0)*zdotc(npw,evc(1,ibnd),1,ppsi_us(1,jbnd),1)* &
(et(ibnd,ik)-et(jbnd,ik))
(et(ibnd,ik)-et(jbnd,ik))
ENDIF
END IF
END DO
END DO
END DO
ENDIF
ENDDO
ENDDO
ENDDO
DEALLOCATE(ppsi)
IF (okvan) DEALLOCATE(ppsi_us)
#ifdef __PARA
@ -143,21 +143,21 @@ SUBROUTINE write_p_avg(filp, spin_component, firstk, lastk)
nbnd, nks2-nks1+1
WRITE (iunout, '(10x,3f10.6,i7)') xk(1,ik),xk(2,ik),xk(3,ik), &
nbnd_occ
DO ipol=1,3
WRITE (iunout, '(i3)') ipol
DO ibnd=nbnd_occ+1,nbnd
WRITE (iunout, '(5f15.8)') &
(ABS(matp(ibnd-nbnd_occ,jbnd,ipol))**2, jbnd=1,nbnd_occ)
END DO
END DO
END IF
END DO
(abs(matp(ibnd-nbnd_occ,jbnd,ipol))**2, jbnd=1,nbnd_occ)
ENDDO
ENDDO
ENDIF
ENDDO
IF (ionode) THEN
CLOSE(iunout)
END IF
ENDIF
DEALLOCATE(matp)
!

158
PP/xctest.f90
View File

@ -5,79 +5,79 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
program xctest
PROGRAM xctest
USE mp, ONLY: mp_start, mp_end
use kinds, only: DP
use funct, only: set_dft_from_indices
implicit none
integer :: nnr = 1000
integer :: nspin = 2
real(DP), allocatable :: rhor( :, : )
real(DP), allocatable :: grhor( :, :, : )
integer iexch,icorr,igcx,igcc
USE kinds, ONLY: DP
USE funct, ONLY: set_dft_from_indices
IMPLICIT NONE
INTEGER :: nnr = 1000
INTEGER :: nspin = 2
real(DP), ALLOCATABLE :: rhor( :, : )
real(DP), ALLOCATABLE :: grhor( :, :, : )
INTEGER iexch,icorr,igcx,igcc
CALL mp_start()
iexch=1
icorr=3
igcx=1
igcc=3
call set_dft_from_indices(iexch,icorr,igcx,igcc)
CALL set_dft_from_indices(iexch,icorr,igcx,igcc)
open(unit=17,form='unformatted',status='old')
read(17) nnr, nspin
allocate(rhor( nnr, nspin ))
allocate(grhor( nnr, 3, nspin ))
read(17) rhor
read(17) grhor
close(17)
OPEN(unit=17,form='unformatted',status='old')
READ(17) nnr, nspin
ALLOCATE(rhor( nnr, nspin ))
ALLOCATE(grhor( nnr, 3, nspin ))
READ(17) rhor
READ(17) grhor
CLOSE(17)
!CALL test_gcxc( nnr, nspin, rhor, grhor )
CALL test_xc( nnr, nspin, rhor, grhor )
CALL mp_end()
end program xctest
subroutine test_gcxc( nnr, nspin, rhor, grhor )
use kinds, only: DP
CALL mp_end()
END PROGRAM xctest
SUBROUTINE test_gcxc( nnr, nspin, rhor, grhor )
USE kinds, ONLY: DP
! use funct, only: gcxc
implicit none
integer, intent(in) :: nnr, nspin
IMPLICIT NONE
INTEGER, INTENT(in) :: nnr, nspin
real(DP) :: rhor( nnr, nspin )
real(DP) :: grhor( nnr, 3, nspin )
!
real(DP), parameter :: epsr = 1.0d-10, epsg = 1.0d-10
real(DP), parameter :: e2 = 1.0d0
real(DP), PARAMETER :: epsr = 1.0d-10, epsg = 1.0d-10
real(DP), PARAMETER :: e2 = 1.0d0
real(DP) :: grho2( nspin )
real(DP) :: arho, segno
real(DP) :: sx_w, sc_w, v1x_w, v2x_w, v1c_w, v2c_w
real(DP) :: sx, sc, v1x, v2x, v1c, v2c
real(DP) :: sx_m, sc_m, v1x_m, v2x_m, v1c_m, v2c_m
real(DP) :: sx_d, sc_d, v1x_d, v2x_d, v1c_d, v2c_d
integer :: k, is, ipol
INTEGER :: k, is, ipol
do k = 1, nnr
DO k = 1, nnr
!
!
do is = 1, nspin
DO is = 1, nspin
grho2 (is) = grhor(k, 1, is)**2 + grhor(k, 2, is)**2 + grhor(k, 3, is)**2
enddo
ENDDO
!
!
if (nspin == 1) then
IF (nspin == 1) THEN
!
! This is the spin-unpolarised case
!
arho = abs (rhor (k, 1) )
segno = sign (1.d0, rhor (k, 1) )
if (arho > epsr .and. grho2 (1) > epsg) then
IF (arho > epsr .and. grho2 (1) > epsg) THEN
! call gcxc (arho, grho2(1), sx, sc, v1x, v2x, v1c, v2c)
call becke88 (arho, grho2(1), sx, v1x, v2x)
call wrap_b88 (arho, grho2(1), sx_w, v1x_w, v2x_w) ! DEBUG
call glyp (arho, grho2(1), sc, v1c, v2c)
call wrap_glyp (arho, grho2(1), sc_w, v1c_w, v2c_w) ! DEBUG
CALL becke88 (arho, grho2(1), sx, v1x, v2x)
CALL wrap_b88 (arho, grho2(1), sx_w, v1x_w, v2x_w) ! DEBUG
CALL glyp (arho, grho2(1), sc, v1c, v2c)
CALL wrap_glyp (arho, grho2(1), sc_w, v1c_w, v2c_w) ! DEBUG
sx_d = (sx_w - sx) / (abs(sx) + abs(sx_w))
sc_d = (sc_w - sc) / (abs(sc) + abs(sc_w))
@ -85,12 +85,12 @@ subroutine test_gcxc( nnr, nspin, rhor, grhor )
v1c_d = (v1c_w - v1c) / (abs(v1c) + abs(v1c_w))
v2x_d = (v2x_w - v2x) / (abs(v2x) + abs(v2x_w))
v2c_d = (v2c_w - v2c) / (abs(v2c) + abs(v2c_w))
write(18,*) arho,grho2(1), sx_d, sc_d
write(19,*) arho,grho2(1), v1x_d, v1c_d
write(20,*) arho,grho2(1), v2x_w, v2x, v2x_d
write(21,*) arho,grho2(1), v2c_w, v2c, v2c_d
WRITE(18,*) arho,grho2(1), sx_d, sc_d
WRITE(19,*) arho,grho2(1), v1x_d, v1c_d
WRITE(20,*) arho,grho2(1), v2x_w, v2x, v2x_d
WRITE(21,*) arho,grho2(1), v2c_w, v2c, v2c_d
!
! first term of the gradient correction : D(rho*Exc)/D(rho)
@ -102,37 +102,37 @@ subroutine test_gcxc( nnr, nspin, rhor, grhor )
! h (k, 1, 1) = e2 * (v2x + v2c)
! etxc = etxc + e2 * (sx + sc) * segno
else
ELSE
! h (k, 1, 1) = 0.d0
sx = 0.0d0
sc = 0.0d0
endif
ENDIF
!
endif
ENDIF
!
end do
ENDDO
return
end subroutine test_gcxc
RETURN
END SUBROUTINE test_gcxc
!
!
!
subroutine test_xc( nnr, nspin, rhor, grhor )
use kinds, only: DP
use funct, only: get_iexch, get_icorr, get_igcx, get_igcc
SUBROUTINE test_xc( nnr, nspin, rhor, grhor )
USE kinds, ONLY: DP
USE funct, ONLY: get_iexch, get_icorr, get_igcx, get_igcc
implicit none
integer, intent(in) :: nnr, nspin
IMPLICIT NONE
INTEGER, INTENT(in) :: nnr, nspin
real(DP) :: rhor( nnr, nspin )
real(DP) :: grhor( nnr, 3, nspin )
!
real(DP) :: rhon( nnr, nspin )
real(DP) :: grhon( nnr, 3, nspin )
real(DP) :: exc, excn, rhod, grhod
integer :: ir, is, ipol
integer iexch,icorr,igcx,igcc
INTEGER :: ir, is, ipol
INTEGER iexch,icorr,igcx,igcc
iexch = get_iexch()
@ -145,41 +145,41 @@ subroutine test_xc( nnr, nspin, rhor, grhor )
!
! original CP xc selection
!
if (iexch==1.and.icorr==1.and.igcx==0.and.igcc==0) then
IF (iexch==1.and.icorr==1.and.igcx==0.and.igcc==0) THEN
! LDA (Perdew-Zunger)
call expxc(nnr,nspin,rhor,exc)
else if (iexch==1.and.icorr==4.and.igcx==2.and.igcc==2) then
CALL expxc(nnr,nspin,rhor,exc)
ELSEIF (iexch==1.and.icorr==4.and.igcx==2.and.igcc==2) THEN
! PW91
call ggapwold(nnr,nspin,grhor,rhor,exc)
else if (iexch==1.and.icorr==3.and.igcx==1.and.igcc==3) then
CALL ggapwold(nnr,nspin,grhor,rhor,exc)
ELSEIF (iexch==1.and.icorr==3.and.igcx==1.and.igcc==3) THEN
! BLYP
call ggablyp4(nnr,nspin,grhor,rhor,exc)
else if (iexch==1.and.icorr==4.and.igcx==3.and.igcc==4) then
CALL ggablyp4(nnr,nspin,grhor,rhor,exc)
ELSEIF (iexch==1.and.icorr==4.and.igcx==3.and.igcc==4) THEN
! PBE
call ggapbe(nnr,nspin,grhor,rhor,exc)
else
call errore('exc-cor','no such exch-corr',1)
end if
CALL ggapbe(nnr,nspin,grhor,rhor,exc)
ELSE
CALL errore('exc-cor','no such exch-corr',1)
ENDIF
!
! Wrapper to PW xc selection
!
call exch_corr_cp(nnr,nspin,grhon,rhon,excn)
CALL exch_corr_cp(nnr,nspin,grhon,rhon,excn)
!
write(6,*) 'EXC = ', exc, excn
do is = 1, nspin
do ir = 1, nnr
WRITE(6,*) 'EXC = ', exc, excn
DO is = 1, nspin
DO ir = 1, nnr
rhod = abs( rhor( ir, is ) - rhon( ir, is ) ) / ( abs( rhor( ir, is ) ) + abs( rhon( ir, is ) ) )
WRITE(18,100) ir,is,rhod
end do
end do
do is = 1, nspin
do ir = 1, nnr
do ipol = 1, 3
ENDDO
ENDDO
DO is = 1, nspin
DO ir = 1, nnr
DO ipol = 1, 3
grhod = abs( grhor( ir, ipol, is ) - grhon( ir, ipol, is ) ) / &
( abs( grhor( ir, ipol, is ) ) + abs( grhon( ir, ipol, is ) ) )
WRITE(19,100) ir,is,grhod
end do
end do
end do
ENDDO
ENDDO
ENDDO
100 FORMAT( I5, I2, 1X, E15.8, 1X, E15.8 )
end subroutine test_xc
END SUBROUTINE test_xc

204
PP/xsf.f90
View File

@ -11,38 +11,38 @@
! -------------------------------------------------------------------
! this routine writes the crystal structure in XSF format
! -------------------------------------------------------------------
subroutine xsf_struct (alat, at, nat, tau, atm, ityp, ounit)
USE kinds, only : DP
USE constants, only : BOHR_RADIUS_ANGS
implicit none
integer :: nat, ityp (nat), ounit
character(len=3) :: atm(*)
SUBROUTINE xsf_struct (alat, at, nat, tau, atm, ityp, ounit)
USE kinds, ONLY : DP
USE constants, ONLY : BOHR_RADIUS_ANGS
IMPLICIT NONE
INTEGER :: nat, ityp (nat), ounit
CHARACTER(len=3) :: atm(*)
real(DP) :: alat, tau (3, nat), at (3, 3)
! --
integer :: i, j, n
INTEGER :: i, j, n
real(DP) :: at1 (3, 3)
! convert lattice vectors to ANGSTROM units ...
do i=1,3
do j=1,3
DO i=1,3
DO j=1,3
at1(j,i) = at(j,i)*alat*BOHR_RADIUS_ANGS
enddo
enddo
ENDDO
ENDDO
write(ounit,*) 'CRYSTAL'
write(ounit,*) 'PRIMVEC'
write(ounit,'(2(3F15.9/),3f15.9)') at1
write(ounit,*) 'PRIMCOORD'
write(ounit,*) nat, 1
WRITE(ounit,*) 'CRYSTAL'
WRITE(ounit,*) 'PRIMVEC'
WRITE(ounit,'(2(3F15.9/),3f15.9)') at1
WRITE(ounit,*) 'PRIMCOORD'
WRITE(ounit,*) nat, 1
do n=1,nat
DO n=1,nat
! positions are in Angstroms
write(ounit,'(a3,3x,3f15.9)') atm(ityp(n)), &
WRITE(ounit,'(a3,3x,3f15.9)') atm(ityp(n)), &
tau(1,n)*alat*BOHR_RADIUS_ANGS, &
tau(2,n)*alat*BOHR_RADIUS_ANGS, &
tau(3,n)*alat*BOHR_RADIUS_ANGS
enddo
return
end subroutine xsf_struct
ENDDO
RETURN
END SUBROUTINE xsf_struct
@ -50,161 +50,161 @@ end subroutine xsf_struct
! this routine writes the 3D scalar field (i.e. uniform mesh of points)
! in XSF format using the FFT mesh (i.e. fast write)
! -------------------------------------------------------------------
subroutine xsf_fast_datagrid_3d &
SUBROUTINE xsf_fast_datagrid_3d &
(rho, nr1, nr2, nr3, nrx1, nrx2, nrx3, at, alat, ounit)
USE kinds, only : DP
USE kinds, ONLY : DP
USE constants, ONLY : BOHR_RADIUS_ANGS
implicit none
integer :: nrx1, nrx2, nrx3, nr1, nr2, nr3, ounit
IMPLICIT NONE
INTEGER :: nrx1, nrx2, nrx3, nr1, nr2, nr3, ounit
real(DP) :: alat, at (3, 3), rho(nrx1,nrx2,nrx3)
! --
integer :: i1, i2, i3, ix, iy, iz, count, i, &
INTEGER :: i1, i2, i3, ix, iy, iz, count, i, &
ind_x(10), ind_y(10),ind_z(10)
! XSF scalar-field header
write(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_3D'
write(ounit,'(a)') '3D_PWSCF'
write(ounit,'(a)') 'DATAGRID_3D_UNKNOWN'
WRITE(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_3D'
WRITE(ounit,'(a)') '3D_PWSCF'
WRITE(ounit,'(a)') 'DATAGRID_3D_UNKNOWN'
! number of points in each direction
write(ounit,*) nr1+1, nr2+1, nr3+1
WRITE(ounit,*) nr1+1, nr2+1, nr3+1
! origin
write(ounit,'(3f10.6)') 0.0d0, 0.0d0, 0.0d0
WRITE(ounit,'(3f10.6)') 0.0d0, 0.0d0, 0.0d0
! 1st spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*at(i,1),i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*at(i,1),i=1,3) ! in ANSTROMS
! 2nd spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*at(i,2),i=1,3)
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*at(i,2),i=1,3)
! 3rd spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*at(i,3),i=1,3)
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*at(i,3),i=1,3)
count=0
do i3=0,nr3
DO i3=0,nr3
!iz = mod(i3,nr3)
iz = mod(i3,nr3) + 1
do i2=0,nr2
DO i2=0,nr2
!iy = mod(i2,nr2)
iy = mod(i2,nr2) + 1
do i1=0,nr1
DO i1=0,nr1
!ix = mod(i1,nr1)
ix = mod(i1,nr1) + 1
!ii = (1+ix) + iy*nrx1 + iz*nrx1*nrx2
if (count.lt.6) then
IF (count<6) THEN
count = count + 1
!ind(count) = ii
else
write(ounit,'(6e13.5)') &
ELSE
WRITE(ounit,'(6e13.5)') &
(rho(ind_x(i),ind_y(i),ind_z(i)),i=1,6)
count=1
!ind(count) = ii
endif
ENDIF
ind_x(count) = ix
ind_y(count) = iy
ind_z(count) = iz
enddo
enddo
enddo
write(ounit,'(6e13.5:)') (rho(ind_x(i),ind_y(i),ind_z(i)),i=1,count)
write(ounit,'(a)') 'END_DATAGRID_3D'
write(ounit,'(a)') 'END_BLOCK_DATAGRID_3D'
return
end subroutine xsf_fast_datagrid_3d
ENDDO
ENDDO
ENDDO
WRITE(ounit,'(6e13.5:)') (rho(ind_x(i),ind_y(i),ind_z(i)),i=1,count)
WRITE(ounit,'(a)') 'END_DATAGRID_3D'
WRITE(ounit,'(a)') 'END_BLOCK_DATAGRID_3D'
RETURN
END SUBROUTINE xsf_fast_datagrid_3d
subroutine xsf_datagrid_2d (rho, nx, ny, m1, m2, x0, e1, e2, alat, ounit)
USE kinds, only : DP
SUBROUTINE xsf_datagrid_2d (rho, nx, ny, m1, m2, x0, e1, e2, alat, ounit)
USE kinds, ONLY : DP
USE constants, ONLY : BOHR_RADIUS_ANGS
implicit none
integer :: nx, ny, ounit
IMPLICIT NONE
INTEGER :: nx, ny, ounit
real(DP) :: m1, m2, alat, x0(3), e1(3), e2(3), rho(2, nx, ny)
! --
integer :: ix, iy, count, i, ind_x(10), ind_y(10)
INTEGER :: ix, iy, count, i, ind_x(10), ind_y(10)
! XSF scalar-field header
write(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_2D'
write(ounit,'(a)') '2D_PWSCF'
write(ounit,'(a)') 'DATAGRID_2D_UNKNOWN'
WRITE(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_2D'
WRITE(ounit,'(a)') '2D_PWSCF'
WRITE(ounit,'(a)') 'DATAGRID_2D_UNKNOWN'
! number of points in each direction
write(ounit,*) nx, ny
WRITE(ounit,*) nx, ny
! origin
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*x0(i),i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*x0(i),i=1,3) ! in ANSTROMS
! 1st spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e1(i)*m1,i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e1(i)*m1,i=1,3) ! in ANSTROMS
! 2nd spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e2(i)*m2,i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e2(i)*m2,i=1,3) ! in ANSTROMS
count=0
do iy=1,ny
do ix=1,nx
if (count < 6) then
DO iy=1,ny
DO ix=1,nx
IF (count < 6) THEN
count = count + 1
else
write(ounit,'(6e13.5)') (rho(1,ind_x(i),ind_y(i)),i=1,6)
ELSE
WRITE(ounit,'(6e13.5)') (rho(1,ind_x(i),ind_y(i)),i=1,6)
count=1
endif
ENDIF
ind_x(count) = ix
ind_y(count) = iy
enddo
enddo
ENDDO
ENDDO
write(ounit,'(6e13.5:)') (rho(1,ind_x(i),ind_y(i)),i=1,count)
write(ounit,'(a)') 'END_DATAGRID_2D'
write(ounit,'(a)') 'END_BLOCK_DATAGRID_2D'
return
end subroutine xsf_datagrid_2d
WRITE(ounit,'(6e13.5:)') (rho(1,ind_x(i),ind_y(i)),i=1,count)
WRITE(ounit,'(a)') 'END_DATAGRID_2D'
WRITE(ounit,'(a)') 'END_BLOCK_DATAGRID_2D'
RETURN
END SUBROUTINE xsf_datagrid_2d
subroutine xsf_datagrid_3d &
SUBROUTINE xsf_datagrid_3d &
(rho, nx, ny, nz, m1, m2, m3, x0, e1, e2, e3, alat, ounit)
USE kinds, only : DP
USE kinds, ONLY : DP
USE constants, ONLY : BOHR_RADIUS_ANGS
implicit none
integer :: nx, ny, nz, ounit
IMPLICIT NONE
INTEGER :: nx, ny, nz, ounit
real(DP) :: m1, m2, m3, alat, x0(3), e1(3),e2(3),e3(3), rho(nx, ny, nz)
! --
integer :: ix, iy, iz, count, i, ind_x(10), ind_y(10), ind_z(10)
INTEGER :: ix, iy, iz, count, i, ind_x(10), ind_y(10), ind_z(10)
! XSF scalar-field header
write(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_3D'
write(ounit,'(a)') '3D_PWSCF'
write(ounit,'(a)') 'DATAGRID_3D_UNKNOWN'
WRITE(ounit,'(a)') 'BEGIN_BLOCK_DATAGRID_3D'
WRITE(ounit,'(a)') '3D_PWSCF'
WRITE(ounit,'(a)') 'DATAGRID_3D_UNKNOWN'
! number of points in each direction
write(ounit,*) nx, ny, nz
WRITE(ounit,*) nx, ny, nz
! origin
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*x0(i),i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*x0(i),i=1,3) ! in ANSTROMS
! 1st spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e1(i)*m1,i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e1(i)*m1,i=1,3) ! in ANSTROMS
! 2nd spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e2(i)*m2,i=1,3) ! in ANSTROMS
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e2(i)*m2,i=1,3) ! in ANSTROMS
! 3rd spanning (=lattice) vector
write(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e3(i)*m3,i=1,3)
WRITE(ounit,'(3f10.6)') (BOHR_RADIUS_ANGS*alat*e3(i)*m3,i=1,3)
count=0
do iz=1,nz
do iy=1,ny
do ix=1,nx
if (count.lt.6) then
DO iz=1,nz
DO iy=1,ny
DO ix=1,nx
IF (count<6) THEN
count = count + 1
else
write(ounit,'(6e13.5)') (rho(ind_x(i),ind_y(i),ind_z(i)),i=1,6)
ELSE
WRITE(ounit,'(6e13.5)') (rho(ind_x(i),ind_y(i),ind_z(i)),i=1,6)
count=1
endif
ENDIF
ind_x(count) = ix
ind_y(count) = iy
ind_z(count) = iz
enddo
enddo
enddo
ENDDO
ENDDO
ENDDO
write(ounit,'(6e13.5:)') (rho(ind_x(i),ind_y(i),ind_z(i)),i=1,count)
write(ounit,'(a)') 'END_DATAGRID_3D'
write(ounit,'(a)') 'END_BLOCK_DATAGRID_3D'
return
end subroutine xsf_datagrid_3d
WRITE(ounit,'(6e13.5:)') (rho(ind_x(i),ind_y(i),ind_z(i)),i=1,count)
WRITE(ounit,'(a)') 'END_DATAGRID_3D'
WRITE(ounit,'(a)') 'END_BLOCK_DATAGRID_3D'
RETURN
END SUBROUTINE xsf_datagrid_3d