mirror of https://gitlab.com/QEF/q-e.git
173 lines
6.1 KiB
Fortran
173 lines
6.1 KiB
Fortran
!
|
|
! Copyright (C) 2001-2013 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 .
|
|
!
|
|
!
|
|
|
|
!routines for the set up of terms related with the calòculation
|
|
!of the polarizability for partially occupied states
|
|
|
|
|
|
subroutine pola_partial(numpw,ispin)
|
|
!NOT_TO_BE_INCLUDED_START
|
|
!this subroutine calculates the basis for every v
|
|
!the minimal orthonormal basis for the w_v(r)*w^P'_i(r) products
|
|
!the occupancies are from variable wg and ste to range 0,1
|
|
|
|
USE io_global, ONLY : stdout, ionode, ionode_id
|
|
USE io_files, ONLY : prefix, tmp_dir, diropn
|
|
USE kinds, ONLY : DP
|
|
USE wannier_gw
|
|
USE gvect
|
|
USE constants, ONLY : e2, pi, tpi, fpi
|
|
USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2
|
|
USE wvfct, ONLY : npwx, npw, nbnd, wg
|
|
USE gvecw, ONLY : ecutwfc
|
|
USE wavefunctions, ONLY : evc, psic
|
|
USE mp, ONLY : mp_sum, mp_barrier, mp_bcast
|
|
USE mp_world, ONLY : mpime,nproc, world_comm
|
|
USE mp_pools, ONLY : intra_pool_comm
|
|
USE gvecs, ONLY : doublegrid
|
|
USE fft_custom_gwl
|
|
USE mp_wave, ONLY : mergewf,splitwf
|
|
USE fft_base, ONLY : dfftp, dffts
|
|
USE fft_interfaces, ONLY : fwfft, invfft
|
|
USE lsda_mod, ONLY : lsda, nspin
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
INTEGER, EXTERNAL :: find_free_unit
|
|
INTEGER, INTENT(in) :: numpw!dimension of polarization basis
|
|
INTEGER, INTENT(in) :: ispin! spin channel
|
|
|
|
COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:),p_basis(:,:),p_basis_t(:,:),evc_t(:,:)
|
|
INTEGER :: iw,ii,iv,jv
|
|
INTEGER :: iungprod,iun
|
|
LOGICAL :: exst
|
|
REAL(kind=DP), ALLOCATABLE :: evc_r(:,:), prod_r(:), psi_psi_phi(:)
|
|
COMPLEX(kind=DP), ALLOCATABLE :: prod_g(:)
|
|
|
|
TYPE(fft_cus) :: fc
|
|
|
|
fc%ecutt=ecutwfc
|
|
fc%dual_t=dual_vt
|
|
|
|
write(stdout,*) 'Call initialize_fft_custom'
|
|
FLUSH(stdout)
|
|
call initialize_fft_custom(fc)
|
|
allocate(evc_g(fc%ngmt_g))
|
|
|
|
iungprod = find_free_unit()
|
|
CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst )
|
|
!read polarizability basis functions
|
|
allocate(p_basis(max_ngm,numpw))
|
|
do iw=1,numpw
|
|
call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1)
|
|
enddo
|
|
|
|
close(iungprod)
|
|
|
|
!now polarizability basis are put on the ordering of the redueced grid, if required
|
|
allocate(p_basis_t(fc%npwt,numpw))
|
|
if(fc%dual_t==4.d0) then
|
|
p_basis_t(1:npw,1:numpw)=p_basis(1:npw,1:numpw)
|
|
else
|
|
do ii=1,numpw
|
|
call mergewf(p_basis(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm)
|
|
call splitwf(p_basis_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm)
|
|
enddo
|
|
endif
|
|
|
|
|
|
allocate(evc_t(fc%npwt,num_nbndv(ispin)))
|
|
if(fc%dual_t==4.d0) then
|
|
evc_t(1:npw,1:num_nbndv(ispin))=evc(1:npw,1:num_nbndv(ispin))
|
|
else
|
|
do ii=1,num_nbndv(ispin)
|
|
call mergewf(evc(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm)
|
|
call splitwf(evc_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm)
|
|
enddo
|
|
endif
|
|
!put KS wfcs in real space
|
|
allocate(evc_r(fc%nrxxt,num_nbndv(ispin)))
|
|
do iv=1,num_nbndv(ispin),2
|
|
psic(:)=(0.d0,0.d0)
|
|
if(iv==num_nbndv(ispin)) then
|
|
psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv)
|
|
psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) )
|
|
else
|
|
psic(fc%nlt(1:fc%npwt))=evc_t(1:fc%npwt,iv)+(0.d0,1.d0)*evc_t(1:fc%npwt,iv+1)
|
|
psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) )+(0.d0,1.d0)*CONJG( evc_t(1:fc%npwt,iv+1) )
|
|
endif
|
|
CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 )
|
|
evc_r(1:fc%nrxxt,iv)= DBLE(psic(1:fc%nrxxt))
|
|
if(iv/=num_nbndv(ispin)) evc_r(1:fc%nrxxt,iv+1)= DIMAG(psic(1:fc%nrxxt))
|
|
|
|
enddo
|
|
!open file and write occupancies
|
|
if(ionode) then
|
|
iun=find_free_unit()
|
|
if(ispin==1) then
|
|
open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.occ_mat', status='unknown',form='unformatted')
|
|
else
|
|
open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.occ_mat2', status='unknown',form='unformatted')
|
|
endif
|
|
write(iun) num_nbndv_min(ispin)
|
|
write(iun) num_nbndv(ispin)
|
|
write(iun) numpw
|
|
if(nspin==1) then
|
|
write(iun) wg(1:num_nbndv(ispin),ispin)/2.d0
|
|
else
|
|
write(iun) wg(1:num_nbndv(ispin),ispin)
|
|
endif
|
|
endif
|
|
|
|
|
|
|
|
|
|
!loop on partially occupied states
|
|
allocate(prod_r(fc%nrxxt))
|
|
allocate(prod_g(fc%npwt),psi_psi_phi(numpw))
|
|
do iv=num_nbndv_min(ispin)+1,num_nbndv(ispin)
|
|
!loop on all states
|
|
do jv=1,num_nbndv(ispin)
|
|
prod_r(1:fc%nrxxt)=evc_r(1:fc%nrxxt,iv)*evc_r(1:fc%nrxxt,jv)
|
|
psic(1:fc%nrxxt)=dcmplx(prod_r(1:fc%nrxxt),0.d0)
|
|
CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 )
|
|
prod_g(1:fc%npwt) = psic(fc%nlt(1:fc%npwt))
|
|
|
|
|
|
!do product with polarizability basis
|
|
call dgemm('T','N',numpw,1,2*fc%npwt,2.0,p_basis_t,2*fc%npwt,prod_g,2*fc%npwt,0.d0,psi_psi_phi,numpw)
|
|
if(fc%gstart_t==2) then
|
|
do ii=1,numpw
|
|
psi_psi_phi(ii)=psi_psi_phi(ii)-dble(conjg(p_basis_t(1,ii))*prod_g(1))
|
|
enddo
|
|
endif
|
|
call mp_sum(psi_psi_phi,world_comm)
|
|
if(ionode) write(iun) psi_psi_phi(1:numpw)
|
|
enddo
|
|
enddo
|
|
!write
|
|
|
|
|
|
|
|
|
|
if(ionode) close(iun)
|
|
write(stdout,*) 'Call deallocate_fft_custom'
|
|
FLUSH(stdout)
|
|
deallocate(evc_g,p_basis,p_basis_t)
|
|
deallocate(evc_t,evc_r)
|
|
deallocate(prod_r,prod_g)
|
|
deallocate(psi_psi_phi)
|
|
call deallocate_fft_custom(fc)
|
|
|
|
return
|
|
!NOT_TO_BE_INCLUDED_END
|
|
end subroutine pola_partial
|