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

Improving code readability: ran src-normal on the TDDFPT src. 

git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@7738 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
sbinnie 2011-05-03 13:47:30 +00:00
parent 68ebc624bc
commit a5c1955fd0
32 changed files with 4238 additions and 4238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
TDDFPT/src/bcast_lr_input.f90
View File

@ -6,58 +6,58 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine bcast_lr_input
SUBROUTINE bcast_lr_input
!-----------------------------------------------------------------------
!
! The first processor sends the input to all the other processors
!
!
! Modified by Osman Baris Malcioglu in 2009
! Modified by Osman Baris Malcioglu in 2009
#ifdef __PARA
#include "f_defs.h"
use lr_variables
use realus, only: real_space, real_space_debug
use mp, only: mp_bcast, mp_barrier
use io_files, only: tmp_dir, prefix, wfc_dir
USE lr_variables
USE realus, ONLY: real_space, real_space_debug
USE mp, ONLY: mp_bcast, mp_barrier
USE io_files, ONLY: tmp_dir, prefix, wfc_dir
USE control_flags, ONLY: tqr
USE charg_resp, ONLY: omeg, w_T_prefix, w_T_npol,epsil
USE io_global, ONLY: ionode, ionode_id
USE mp_global, ONLY: intra_image_comm
implicit none
IMPLICIT NONE
!
!
!
call mp_barrier()
call mp_bcast (lr_io_level, ionode_id )
call mp_bcast (itermax, ionode_id )
call mp_bcast (itermax_int, ionode_id )
call mp_bcast (charge_response, ionode_id )
call mp_bcast (project, ionode_id )
call mp_bcast (restart, ionode_id )
call mp_bcast (restart_step, ionode_id )
call mp_bcast (lr_verbosity, ionode_id )
call mp_bcast (prefix, ionode_id )
call mp_bcast (tmp_dir, ionode_id )
call mp_bcast (wfc_dir, ionode_id )
call mp_bcast (LR_polarization, ionode_id )
call mp_bcast (ltammd, ionode_id )
!
CALL mp_barrier()
CALL mp_bcast (lr_io_level, ionode_id )
CALL mp_bcast (itermax, ionode_id )
CALL mp_bcast (itermax_int, ionode_id )
CALL mp_bcast (charge_response, ionode_id )
CALL mp_bcast (project, ionode_id )
CALL mp_bcast (restart, ionode_id )
CALL mp_bcast (restart_step, ionode_id )
CALL mp_bcast (lr_verbosity, ionode_id )
CALL mp_bcast (prefix, ionode_id )
CALL mp_bcast (tmp_dir, ionode_id )
CALL mp_bcast (wfc_dir, ionode_id )
CALL mp_bcast (LR_polarization, ionode_id )
CALL mp_bcast (ltammd, ionode_id )
!call mp_bcast (broadening, ionode_id )
call mp_bcast (real_space, ionode_id )
call mp_bcast (real_space_debug, ionode_id )
call mp_bcast (tmp_dir, ionode_id )
call mp_bcast (tqr, ionode_id )
call mp_bcast (test_case_no, ionode_id )
call mp_bcast (omeg, ionode_id )
call mp_bcast (epsil, ionode_id )
call mp_bcast (w_T_prefix, ionode_id )
call mp_bcast (w_T_npol, ionode_id )
call mp_bcast (n_ipol, ionode_id )
call mp_bcast (plot_type, ionode_id )
call mp_bcast (no_hxc, ionode_id )
call mp_bcast (bgz_suffix, ionode_id )
call mp_barrier()
CALL mp_bcast (real_space, ionode_id )
CALL mp_bcast (real_space_debug, ionode_id )
CALL mp_bcast (tmp_dir, ionode_id )
CALL mp_bcast (tqr, ionode_id )
CALL mp_bcast (test_case_no, ionode_id )
CALL mp_bcast (omeg, ionode_id )
CALL mp_bcast (epsil, ionode_id )
CALL mp_bcast (w_T_prefix, ionode_id )
CALL mp_bcast (w_T_npol, ionode_id )
CALL mp_bcast (n_ipol, ionode_id )
CALL mp_bcast (plot_type, ionode_id )
CALL mp_bcast (no_hxc, ionode_id )
CALL mp_bcast (bgz_suffix, ionode_id )
CALL mp_barrier()
!print *, "bcast lr input finished"
!print *, "variables"
!print *, "prefix=", prefix
@ -67,5 +67,5 @@ subroutine bcast_lr_input
!print *, "omeg=",omeg
!print *, "test_case_no=",test_case_no
#endif
return
end subroutine bcast_lr_input
RETURN
END SUBROUTINE bcast_lr_input

168
TDDFPT/src/lr_alloc_init.f90
View File

@ -1,94 +1,94 @@
!-----------------------------------------------------------------------
subroutine lr_alloc_init()
SUBROUTINE lr_alloc_init()
!---------------------------------------------------------------------
! ... allocates and initialises linear response variables
!---------------------------------------------------------------------
! Modified by Osman Baris Malcioglu in 2009
! Modified by Osman Baris Malcioglu in 2009
#include "f_defs.h"
!
use grid_dimensions, only : nrxx
use smooth_grid_dimensions, only : nrxxs
use klist, only : nks
use lr_variables
use uspp, only : nkb
use lsda_mod, only : nspin
use wvfct, only : npwx, nbnd
use control_flags, only : gamma_only
USE grid_dimensions, ONLY : nrxx
USE smooth_grid_dimensions, ONLY : nrxxs
USE klist, ONLY : nks
USE lr_variables
USE uspp, ONLY : nkb
USE lsda_mod, ONLY : nspin
USE wvfct, ONLY : npwx, nbnd
USE control_flags, ONLY : gamma_only
USE io_global, ONLY : stdout
USE charg_resp, ONLY : w_T, w_T_beta_store, w_T_gamma_store,w_T_zeta_store,w_T_npol,chi
use realus, only : igk_k, npw_k
use control_ph, ONLY : nbnd_occ
USE realus, ONLY : igk_k, npw_k
USE control_ph, ONLY : nbnd_occ
USE noncollin_module, ONLY : nspin_mag
USE eqv, ONLY : dmuxc
use wavefunctions_module, only : evc
use kinds, only : dp
USE wavefunctions_module, ONLY : evc
USE kinds, ONLY : dp
!
implicit none
IMPLICIT NONE
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_alloc_init>")')
endif
if (lr_verbosity > 7) THEN
ENDIF
IF (lr_verbosity > 7) THEN
WRITE(stdout,'("NPWX=",I15)') npwx
WRITE(stdout,'("NBND=",I15)') nbnd
WRITE(stdout,'("NKS=",I15)') nks
WRITE(stdout,'("NRXX=",I15)') nrxx
WRITE(stdout,'("NSPIN_MAG=",I15)') nspin_mag
endif
ENDIF
!
if (allocated(evc)) then
deallocate(evc)
allocate(evc(npwx,nbnd))
endif
allocate(evc0(npwx,nbnd,nks))
allocate(sevc0(npwx,nbnd,nks))
if (project) then
IF (allocated(evc)) THEN
DEALLOCATE(evc)
ALLOCATE(evc(npwx,nbnd))
ENDIF
ALLOCATE(evc0(npwx,nbnd,nks))
ALLOCATE(sevc0(npwx,nbnd,nks))
IF (project) THEN
WRITE(stdout,'(5x,"Allocating ",I5," extra bands for projection")') nbnd_total-nbnd
allocate(evc0_virt(npwx,(nbnd_total-nbnd),nks))
ALLOCATE(evc0_virt(npwx,(nbnd_total-nbnd),nks))
!allocate(sevc0_virt(npwx,(nbnd_total-nbnd),nks))
allocate(F(nbnd,(nbnd_total-nbnd),n_ipol))
allocate(R(nbnd,(nbnd_total-nbnd),n_ipol))
allocate(chi(3,3))
ALLOCATE(F(nbnd,(nbnd_total-nbnd),n_ipol))
ALLOCATE(R(nbnd,(nbnd_total-nbnd),n_ipol))
ALLOCATE(chi(3,3))
chi(:,:)=cmplx(0.0d0,0.0d0,dp)
F(:,:,:)=cmplx(0.0d0,0.0d0,dp)
R(:,:,:)=cmplx(0.0d0,0.0d0,dp)
endif
ENDIF
!
allocate(evc1_old(npwx,nbnd,nks,2))
allocate(evc1(npwx,nbnd,nks,2))
allocate(evc1_new(npwx,nbnd,nks,2))
allocate(sevc1_new(npwx,nbnd,nks,2))
allocate(d0psi(npwx,nbnd,nks,n_ipol))
ALLOCATE(evc1_old(npwx,nbnd,nks,2))
ALLOCATE(evc1(npwx,nbnd,nks,2))
ALLOCATE(evc1_new(npwx,nbnd,nks,2))
ALLOCATE(sevc1_new(npwx,nbnd,nks,2))
ALLOCATE(d0psi(npwx,nbnd,nks,n_ipol))
!
allocate(revc0(nrxxs,nbnd,nks))
ALLOCATE(revc0(nrxxs,nbnd,nks))
!
allocate(rho_1(nrxx,nspin_mag))
ALLOCATE(rho_1(nrxx,nspin_mag))
rho_1(:,:)=0.0d0
!allocate(rho_tot(nrxx))
if (charge_response == 1 ) then
IF (charge_response == 1 ) THEN
!allocate(rho_1_tot(nrxx,nspin_mag)) !Due to broadening this is now done in lr_charg_resp
!rho_1_tot(:,:)=0.0d0
!print *,"allocating beta w_t"
allocate(w_T_beta_store(itermax_int))
allocate(w_T_gamma_store(itermax_int))
allocate(w_T_zeta_store(w_T_npol,itermax_int))
allocate(w_T(itermax_int))
ALLOCATE(w_T_beta_store(itermax_int))
ALLOCATE(w_T_gamma_store(itermax_int))
ALLOCATE(w_T_zeta_store(w_T_npol,itermax_int))
ALLOCATE(w_T(itermax_int))
w_T_gamma_store(:)=0.0d0
w_T_beta_store(:)=0.0d0
w_T_zeta_store(:,:)=cmplx(0.0d0,0.0d0,dp)
endif
ENDIF
!if (charge_response /=0) then
! allocate(w_T(itermax_int))
!endif
allocate(dmuxc ( nrxx , nspin , nspin))
ALLOCATE(dmuxc ( nrxx , nspin , nspin))
!print *, "dmuxc ALLOCATED",allocated(dmuxc)," SIZE=",size(dmuxc)
!print *, "nks=",nks
!allocate (nbnd_occ (nks))
!
evc0(:,:,:)=(0.0d0,0.0d0)
evc1_old(:,:,:,:)=(0.0d0,0.0d0)
evc1(:,:,:,:)=(0.0d0,0.0d0)
@ -97,67 +97,67 @@ subroutine lr_alloc_init()
!rho_tot(:)=0.0d0
d0psi(:,:,:,:)=(0.0d0,0.0d0)
!
allocate(alpha_store(n_ipol,itermax))
allocate(beta_store(n_ipol,itermax))
allocate(gamma_store(n_ipol,itermax))
allocate(zeta_store(n_ipol,n_ipol,itermax))
ALLOCATE(alpha_store(n_ipol,itermax))
ALLOCATE(beta_store(n_ipol,itermax))
ALLOCATE(gamma_store(n_ipol,itermax))
ALLOCATE(zeta_store(n_ipol,n_ipol,itermax))
alpha_store(:,:)=0.0d0
beta_store(:,:)=0.0d0
gamma_store(:,:)=0.0d0
zeta_store(:,:,:)=(0.0d0,0.0d0)
!
if(gamma_only) then
call lr_alloc_init_gamma()
else
call lr_alloc_init_k()
endif
IF(gamma_only) THEN
CALL lr_alloc_init_gamma()
ELSE
CALL lr_alloc_init_k()
ENDIF
!
return
RETURN
!
contains
CONTAINS
!
subroutine lr_alloc_init_gamma()
SUBROUTINE lr_alloc_init_gamma()
!
use becmod, only : allocate_bec_type, bec_type, becp
USE becmod, ONLY : allocate_bec_type, bec_type, becp
!
if (nkb > 0) then
IF (nkb > 0) THEN
#ifdef __STD_F95
if (.not. associated(becp%r)) call allocate_bec_type(nkb,nbnd,becp)
IF (.not. associated(becp%r)) CALL allocate_bec_type(nkb,nbnd,becp)
#else
if (.not. allocated(becp%r)) call allocate_bec_type(nkb,nbnd,becp)
IF (.not. allocated(becp%r)) CALL allocate_bec_type(nkb,nbnd,becp)
#endif
becp%r(:,:)=0.0d0
allocate(becp1(nkb,nbnd))
ALLOCATE(becp1(nkb,nbnd))
becp1(:,:)=0.0d0
if (project) then
allocate(becp1_virt(nkb,nbnd_total-nbnd))
IF (project) THEN
ALLOCATE(becp1_virt(nkb,nbnd_total-nbnd))
becp1_virt(:,:)=0.0d0
endif
endif
ENDIF
ENDIF
!
return
end subroutine lr_alloc_init_gamma
RETURN
END SUBROUTINE lr_alloc_init_gamma
!
subroutine lr_alloc_init_k()
use becmod, only : allocate_bec_type, bec_type, becp
SUBROUTINE lr_alloc_init_k()
USE becmod, ONLY : allocate_bec_type, bec_type, becp
!
if (nkb > 0) then
IF (nkb > 0) THEN
#ifdef __STD_F95
if(.not. associated(becp%k)) call allocate_bec_type(nkb,nbnd,becp)
IF(.not. associated(becp%k)) CALL allocate_bec_type(nkb,nbnd,becp)
#else
if(.not. allocated(becp%k)) call allocate_bec_type(nkb,nbnd,becp)
IF(.not. allocated(becp%k)) CALL allocate_bec_type(nkb,nbnd,becp)
#endif
becp%k(:,:)=(0.0d0,0.0d0)
allocate(becp1_c(nkb,nbnd,nks))
becp1_c(:,:,:)=(0.0d0,0.0d0)
if (project) then
allocate(becp1_c_virt(nkb,nbnd_total-nbnd,nks))
ALLOCATE(becp1_c(nkb,nbnd,nks))
becp1_c(:,:,:)=(0.0d0,0.0d0)
IF (project) THEN
ALLOCATE(becp1_c_virt(nkb,nbnd_total-nbnd,nks))
becp1_c_virt(:,:,:)=(0.0d0,0.0d0)
endif
endif
ENDIF
ENDIF
!
return
end subroutine lr_alloc_init_k
RETURN
END SUBROUTINE lr_alloc_init_k
!
end subroutine lr_alloc_init
END SUBROUTINE lr_alloc_init
!----------------------------------------------------------------------------

412
TDDFPT/src/lr_apply_liouvillian.f90
View File

@ -1,5 +1,5 @@
!-----------------------------------------------------------------------
subroutine lr_apply_liouvillian( evc1, evc1_new, sevc1_new, interaction )
SUBROUTINE lr_apply_liouvillian( evc1, evc1_new, sevc1_new, interaction )
!---------------------------------------------------------------------
! ... applies linear response operator to response wavefunctions
! OBM: or to be more exact this function is responsible for calculating L.q(i) and (L^T).p(i)
@ -13,24 +13,24 @@ subroutine lr_apply_liouvillian( evc1, evc1_new, sevc1_new, interaction )
! Modified by Osman Baris Malcioglu in 2009
#include "f_defs.h"
!
use ions_base, only : ityp, nat, ntyp=>nsp
use cell_base, only : tpiba2
use fft_base, only : dffts
use fft_interfaces, only : fwfft
use gvecs, only : nls, nlsm
use gvect, only : nl, ngm, gstart, g, gg
use grid_dimensions, only : nrxx
use io_global, only : stdout
use kinds, only : dp
use klist, only : nks, xk
use lr_variables, only : evc0, revc0, rho_1, lr_verbosity, ltammd, size_evc, no_hxc
use realus, only : igk_k,npw_k
use lsda_mod, only : nspin
use uspp, only : vkb, nkb, okvan
use uspp_param, only : nhm, nh
use wavefunctions_module, only : psic
use wvfct, only : nbnd, npwx, igk, g2kin, et
use control_flags, only : gamma_only
USE ions_base, ONLY : ityp, nat, ntyp=>nsp
USE cell_base, ONLY : tpiba2
USE fft_base, ONLY : dffts
USE fft_interfaces, ONLY : fwfft
USE gvecs, ONLY : nls, nlsm
USE gvect, ONLY : nl, ngm, gstart, g, gg
USE grid_dimensions, ONLY : nrxx
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE klist, ONLY : nks, xk
USE lr_variables, ONLY : evc0, revc0, rho_1, lr_verbosity, ltammd, size_evc, no_hxc
USE realus, ONLY : igk_k,npw_k
USE lsda_mod, ONLY : nspin
USE uspp, ONLY : vkb, nkb, okvan
USE uspp_param, ONLY : nhm, nh
USE wavefunctions_module, ONLY : psic
USE wvfct, ONLY : nbnd, npwx, igk, g2kin, et
USE control_flags, ONLY : gamma_only
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
bfft_orbital_gamma, calbec_rs_gamma, add_vuspsir_gamma, &
v_loc_psir, s_psir_gamma, real_space_debug, &
@ -42,247 +42,247 @@ subroutine lr_apply_liouvillian( evc1, evc1_new, sevc1_new, interaction )
!
implicit none
IMPLICIT NONE
!
complex(kind=dp),intent(in) :: evc1(npwx,nbnd,nks)
complex(kind=dp),intent(out) :: evc1_new(npwx,nbnd,nks), sevc1_new(npwx,nbnd,nks)
logical, intent(in) :: interaction
COMPLEX(kind=dp),INTENT(in) :: evc1(npwx,nbnd,nks)
COMPLEX(kind=dp),INTENT(out) :: evc1_new(npwx,nbnd,nks), sevc1_new(npwx,nbnd,nks)
LOGICAL, INTENT(in) :: interaction
!
! Local variables
!
integer :: ir, ibnd, ik, ig, ia, mbia
integer :: ijkb0, na, nt, ih, jh, ikb, jkb, iqs,jqs
real(kind=dp), allocatable :: dvrs(:,:), dvrss(:)
complex(kind=dp), allocatable :: dvrs_temp(:,:) !OBM This waste of memory was already there in lr_dv_of_drho
real(kind=dp), allocatable :: d_deeq(:,:,:,:)
complex(kind=dp), allocatable :: spsi1(:,:)
complex(kind=dp) :: fp, fm
REAL(DP), allocatable, dimension(:) :: w1, w2
INTEGER :: ir, ibnd, ik, ig, ia, mbia
INTEGER :: ijkb0, na, nt, ih, jh, ikb, jkb, iqs,jqs
real(kind=dp), ALLOCATABLE :: dvrs(:,:), dvrss(:)
COMPLEX(kind=dp), ALLOCATABLE :: dvrs_temp(:,:) !OBM This waste of memory was already there in lr_dv_of_drho
real(kind=dp), ALLOCATABLE :: d_deeq(:,:,:,:)
COMPLEX(kind=dp), ALLOCATABLE :: spsi1(:,:)
COMPLEX(kind=dp) :: fp, fm
REAL(DP), ALLOCATABLE, DIMENSION(:) :: w1, w2
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_apply_liouvillian>")')
endif
ENDIF
!
call start_clock('lr_apply')
if (interaction) call start_clock('lr_apply_int')
if (.not.interaction) call start_clock('lr_apply_no')
CALL start_clock('lr_apply')
IF (interaction) CALL start_clock('lr_apply_int')
IF (.not.interaction) CALL start_clock('lr_apply_no')
!
allocate( d_deeq(nhm, nhm, nat, nspin) )
ALLOCATE( d_deeq(nhm, nhm, nat, nspin) )
d_deeq(:,:,:,:)=0.0d0
allocate( spsi1(npwx, nbnd) )
ALLOCATE( spsi1(npwx, nbnd) )
spsi1(:,:)=(0.0d0,0.0d0)
!
if( interaction ) then !If true, the full L is calculated
IF( interaction ) THEN !If true, the full L is calculated
ALLOCATE( dvrs(nrxx, nspin) )
ALLOCATE( dvrss(dffts%nnr) )
dvrs(:,:)=0.0d0
dvrss(:)=0.0d0
dvrss(:)=0.0d0
!
call lr_calc_dens( evc1, .false. )
CALL lr_calc_dens( evc1, .false. )
!
if (no_hxc) then
IF (no_hxc) THEN
!OBM no_hxc controls the hartree excange correlation addition, if true, they are not added
dvrs(:,1)=0.0d0
call interpolate (dvrs(:,1),dvrss,-1)
else
CALL interpolate (dvrs(:,1),dvrss,-1)
ELSE
dvrs(:,1)=rho_1(:,1)
!
!call lr_dv_of_drho(dvrs)
allocate( dvrs_temp(nrxx, nspin) )
dvrs_temp=CMPLX(dvrs,0.0d0) !OBM: This memory copy was hidden in lr_dv_of_drho, can it be avoided?
ALLOCATE( dvrs_temp(nrxx, nspin) )
dvrs_temp=cmplx(dvrs,0.0d0) !OBM: This memory copy was hidden in lr_dv_of_drho, can it be avoided?
DEALLOCATE ( dvrs )
call dv_of_drho(0,dvrs_temp,.false.)
CALL dv_of_drho(0,dvrs_temp,.false.)
ALLOCATE ( dvrs(nrxx, nspin) ) !SJB Worth getting rid of this memory bottle neck for the moment.
dvrs=DBLE(dvrs_temp)
deallocate(dvrs_temp)
dvrs=dble(dvrs_temp)
DEALLOCATE(dvrs_temp)
!
if ( okvan ) then
if ( tqr ) then
call newq_r(dvrs,d_deeq,.true.)
else
IF ( okvan ) THEN
IF ( tqr ) THEN
CALL newq_r(dvrs,d_deeq,.true.)
ELSE
ALLOCATE( psic(nrxx) )
psic(:)=(0.0d0,0.0d0)
call newq(dvrs,d_deeq,.true.)
CALL newq(dvrs,d_deeq,.true.)
DEALLOCATE( psic )
endif
endif
call add_paw_to_deeq(d_deeq)
ENDIF
ENDIF
CALL add_paw_to_deeq(d_deeq)
!
call interpolate (dvrs(:,1),dvrss,-1)
endif
CALL interpolate (dvrs(:,1),dvrss,-1)
ENDIF
!
endif
ENDIF
!
ALLOCATE ( psic (nrxx) )
if( gamma_only ) then
IF( gamma_only ) THEN
!
call lr_apply_liouvillian_gamma()
CALL lr_apply_liouvillian_gamma()
!
else
ELSE
!
call lr_apply_liouvillian_k()
CALL lr_apply_liouvillian_k()
!
endif
ENDIF
DEALLOCATE ( psic )
!
if ( interaction .and. (.not.ltammd) ) then
IF ( interaction .and. (.not.ltammd) ) THEN
!
! Normal interaction
!
write(stdout,'(5X,"lr_apply_liouvillian: applying interaction: normal")')
WRITE(stdout,'(5X,"lr_apply_liouvillian: applying interaction: normal")')
!
! Here evc1_new contains the interaction
!
!OBM, blas
!sevc1_new=sevc1_new+(1.0d0,0.0d0)*evc1_new
call zaxpy(size_evc,cmplx(1.0d0,0.0d0,kind=dp),evc1_new(:,:,:),1,sevc1_new(:,:,:),1)
CALL zaxpy(size_evc,cmplx(1.0d0,0.0d0,kind=dp),evc1_new(:,:,:),1,sevc1_new(:,:,:),1)
!
!
else if ( interaction .and. ltammd ) then
ELSEIF ( interaction .and. ltammd ) THEN
!
! Tamm-dancoff interaction
!
write(stdout,'(5X,"lr_apply_liouvillian: applying interaction: tamm-dancoff")')
WRITE(stdout,'(5X,"lr_apply_liouvillian: applying interaction: tamm-dancoff")')
!
! Here evc1_new contains the interaction
!
!OBM, blas
!sevc1_new=sevc1_new+(0.50d0,0.0d0)*evc1_new
call zaxpy(size_evc,cmplx(0.5d0,0.0d0,kind=dp),evc1_new(:,:,:),1,sevc1_new(:,:,:),1)
CALL zaxpy(size_evc,cmplx(0.5d0,0.0d0,kind=dp),evc1_new(:,:,:),1,sevc1_new(:,:,:),1)
!
!
else
ELSE
!
! Non interacting
!
write(stdout,'(5X,"lr_apply_liouvillian: not applying interaction")')
WRITE(stdout,'(5X,"lr_apply_liouvillian: not applying interaction")')
!
end if
ENDIF
!
if (gstart == 2 .and. gamma_only ) sevc1_new(1,:,:)=cmplx(real(sevc1_new(1,:,:),dp),0.0d0,dp)
IF (gstart == 2 .and. gamma_only ) sevc1_new(1,:,:)=cmplx(real(sevc1_new(1,:,:),dp),0.0d0,dp)
! (OBM: Why there is this check?)
if(gstart==2 .and. gamma_only) then
IF(gstart==2 .and. gamma_only) THEN
!
do ik=1,nks
DO ik=1,nks
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
if(lr_verbosity>6) write(stdout,9000) ibnd,1,sevc1_new(1,ibnd,ik)
IF(lr_verbosity>6) WRITE(stdout,9000) ibnd,1,sevc1_new(1,ibnd,ik)
!
if (abs(aimag(sevc1_new(1,ibnd,ik)))>1.0d-12) then
IF (abs(aimag(sevc1_new(1,ibnd,ik)))>1.0d-12) THEN
!
call errore(' lr_apply_liouvillian ',&
CALL errore(' lr_apply_liouvillian ',&
'Imaginary part of G=0 '// &
'component does not equal zero',1)
!
endif
ENDIF
!
enddo
ENDDO
!
enddo
ENDDO
!
end if
ENDIF
!
do ik=1,nks
DO ik=1,nks
!
call sm1_psi(.false.,ik,npwx,npw_k(ik),nbnd,sevc1_new(1,1,ik),evc1_new(1,1,ik))
CALL sm1_psi(.false.,ik,npwx,npw_k(ik),nbnd,sevc1_new(1,1,ik),evc1_new(1,1,ik))
!
enddo
ENDDO
!
IF (allocated(dvrs)) DEALLOCATE(dvrs)
if (allocated(dvrss)) deallocate(dvrss)
deallocate(d_deeq)
deallocate(spsi1)
IF (allocated(dvrss)) DEALLOCATE(dvrss)
DEALLOCATE(d_deeq)
DEALLOCATE(spsi1)
!
9000 FORMAT(/5x,'lr_apply_liouvillian: ibnd=',1X,i2,1X,'sevc1_new(G=0)[',i1,']',2(1x,e12.5)/)
!
call stop_clock('lr_apply')
if (interaction) call stop_clock('lr_apply_int')
if (.not.interaction) call stop_clock('lr_apply_no')
CALL stop_clock('lr_apply')
IF (interaction) CALL stop_clock('lr_apply_int')
IF (.not.interaction) CALL stop_clock('lr_apply_no')
!
return
RETURN
!
contains
CONTAINS
!
subroutine lr_apply_liouvillian_gamma()
SUBROUTINE lr_apply_liouvillian_gamma()
!
!use becmod, only : bec_type,becp
use lr_variables, only : becp1
USE lr_variables, ONLY : becp1
!
real(kind=dp), allocatable :: becp2(:,:)
real(kind=dp), ALLOCATABLE :: becp2(:,:)
!
if ( nkb > 0 .and. okvan ) then
IF ( nkb > 0 .and. okvan ) THEN
!
allocate(becp2(nkb,nbnd))
ALLOCATE(becp2(nkb,nbnd))
becp2(:,:)=0.0d0
!
end if
ENDIF
!
! Now apply to the ground state wavefunctions
! and convert to real space
!
if ( interaction ) then
IF ( interaction ) THEN
!
call start_clock('interaction')
CALL start_clock('interaction')
if (nkb > 0 .and. okvan) then
IF (nkb > 0 .and. okvan) THEN
! calculation of becp2
becp2(:,:) = 0.0d0
!
ijkb0 = 0
!
do nt = 1, ntyp
DO nt = 1, ntyp
!
do na = 1, nat
DO na = 1, nat
!
if ( ityp(na) == nt ) then
IF ( ityp(na) == nt ) THEN
!
do ibnd = 1, nbnd
DO ibnd = 1, nbnd
!
do jh = 1, nh(nt)
DO jh = 1, nh(nt)
!
jkb = ijkb0 + jh
!
do ih = 1, nh(nt)
DO ih = 1, nh(nt)
!
ikb = ijkb0 + ih
becp2(ikb, ibnd) = becp2(ikb, ibnd) + &
d_deeq(ih,jh,na,1) * becp1(jkb,ibnd)
!
enddo
ENDDO
!
enddo
ENDDO
!
enddo
ENDDO
!
ijkb0 = ijkb0 + nh(nt)
!
endif
ENDIF
!
enddo
ENDDO
!
enddo
ENDDO
!end: calculation of becp2
endif
ENDIF
!
! evc1_new is used as a container for the interaction
!
evc1_new(:,:,:)=(0.0d0,0.0d0)
!
do ibnd=1,nbnd,2
DO ibnd=1,nbnd,2
!
! Product with the potential vrs = (vltot+vr)
! revc0 is on smooth grid. psic is used upto smooth grid
do ir=1,dffts%nnr
DO ir=1,dffts%nnr
!
psic(ir)=revc0(ir,ibnd,1)*cmplx(dvrss(ir),0.0d0,dp)
!
enddo
ENDDO
!
!print *,"1"
if (real_space_debug > 7 .and. okvan .and. nkb > 0) then
IF (real_space_debug > 7 .and. okvan .and. nkb > 0) THEN
!THE REAL SPACE PART (modified from s_psi)
!print *, "lr_apply_liouvillian:Experimental interaction part not using vkb"
!fac = sqrt(omega)
@ -309,11 +309,11 @@ contains
!
jkb = ijkb0 + jh
w1(ih) = w1(ih) + becp2(jkb, ibnd)
IF ( ibnd+1 .le. nbnd ) w2(ih) = w2(ih) + becp2(jkb, ibnd+1)
IF ( ibnd+1 <= nbnd ) w2(ih) = w2(ih) + becp2(jkb, ibnd+1)
!
END DO
ENDDO
!
END DO
ENDDO
!
!w1 = w1 * fac
!w2 = w2 * fac
@ -324,218 +324,218 @@ contains
DO ir = 1, mbia
!
iqs = jqs + ir
psic( box_beta(ir,ia) ) = psic( box_beta(ir,ia) ) + betasave(ia,ih,ir)*CMPLX( w1(ih), w2(ih) )
psic( box_beta(ir,ia) ) = psic( box_beta(ir,ia) ) + betasave(ia,ih,ir)*cmplx( w1(ih), w2(ih) )
!
END DO
ENDDO
!
jqs = iqs
!
END DO
ENDDO
!
DEALLOCATE( w1, w2 )
!
END IF
ENDIF
!
END DO
ENDDO
!
END DO
ENDDO
endif
ENDIF
!print *,"2"
!
! Back to reciprocal space This part is equivalent to bfft_orbital_gamma
!
call bfft_orbital_gamma (evc1_new(:,:,1), ibnd, nbnd,.false.)
CALL bfft_orbital_gamma (evc1_new(:,:,1), ibnd, nbnd,.false.)
!print *,"3"
enddo
ENDDO
!
!
if( nkb > 0 .and. okvan .and. real_space_debug <= 7) then
IF( nkb > 0 .and. okvan .and. real_space_debug <= 7) THEN
!The non real_space part
call dgemm( 'N', 'N', 2*npw_k(1), nbnd, nkb, 1.d0, vkb, &
CALL dgemm( 'N', 'N', 2*npw_k(1), nbnd, nkb, 1.d0, vkb, &
2*npwx, becp2, nkb, 1.d0, evc1_new, 2*npwx )
!print *, "lr_apply_liouvillian:interaction part using vkb"
!
end if
call stop_clock('interaction')
ENDIF
CALL stop_clock('interaction')
!
end if
ENDIF
!
! Call h_psi on evc1 such that h.evc1 = sevc1_new
!
call h_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),sevc1_new(1,1,1))
CALL h_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),sevc1_new(1,1,1))
!
! spsi1 = s*evc1
!
if (real_space_debug > 9 ) then
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc1(:,:,1),ibnd,nbnd)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(spsi1,ibnd,nbnd)
enddo
else
call s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi1)
endif
IF (real_space_debug > 9 ) THEN
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc1(:,:,1),ibnd,nbnd)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(spsi1,ibnd,nbnd)
ENDDO
ELSE
CALL s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi1)
ENDIF
!
! Subtract the eigenvalues
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
call zaxpy(npw_k(1), cmplx(-et(ibnd,1),0.0d0,dp), spsi1(:,ibnd), 1, sevc1_new(:,ibnd,1), 1)
CALL zaxpy(npw_k(1), cmplx(-et(ibnd,1),0.0d0,dp), spsi1(:,ibnd), 1, sevc1_new(:,ibnd,1), 1)
!
enddo
ENDDO
!
if( nkb > 0 .and. okvan ) deallocate(becp2)
IF( nkb > 0 .and. okvan ) DEALLOCATE(becp2)
!
return
RETURN
!
end subroutine lr_apply_liouvillian_gamma
END SUBROUTINE lr_apply_liouvillian_gamma
!
subroutine lr_apply_liouvillian_k()
SUBROUTINE lr_apply_liouvillian_k()
!
!use becmod, only : becp
use lr_variables, only : becp1_c
USE lr_variables, ONLY : becp1_c
!
complex(kind=dp), allocatable :: becp2(:,:)
COMPLEX(kind=dp), ALLOCATABLE :: becp2(:,:)
!
if( nkb > 0 .and. okvan ) then
IF( nkb > 0 .and. okvan ) THEN
!
allocate(becp2(nkb,nbnd))
ALLOCATE(becp2(nkb,nbnd))
becp2(:,:)=(0.0d0,0.0d0)
!
endif
ENDIF
!
! Now apply to the ground state wavefunctions
! and convert to real space
!
if ( interaction ) then
IF ( interaction ) THEN
!
call start_clock('interaction')
CALL start_clock('interaction')
!
! evc1_new is used as a container for the interaction
!
evc1_new(:,:,:)=(0.0d0,0.0d0)
!
do ik=1,nks
DO ik=1,nks
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
! Product with the potential vrs = (vltot+vr)
!
do ir=1,dffts%nnr
DO ir=1,dffts%nnr
!
psic(ir)=revc0(ir,ibnd,ik)*cmplx(dvrss(ir),0.0d0,dp)
!
enddo
ENDDO
!
! Back to reciprocal space
!
CALL fwfft ('Wave', psic, dffts)
!
do ig=1,npw_k(ik)
DO ig=1,npw_k(ik)
!
evc1_new(ig,ibnd,ik)=psic(nls(igk_k(ig,ik)))
!
enddo
ENDDO
!
enddo
ENDDO
!
enddo
ENDDO
!
call stop_clock('interaction')
CALL stop_clock('interaction')
!
if ( nkb > 0 .and. okvan ) then
IF ( nkb > 0 .and. okvan ) THEN
!
do ik=1,nks
DO ik=1,nks
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!
becp2(:,:) = 0.0d0
!
ijkb0 = 0
!
do nt = 1, ntyp
DO nt = 1, ntyp
!
do na = 1, nat
DO na = 1, nat
!
if ( ityp(na) == nt ) then
IF ( ityp(na) == nt ) THEN
!
do ibnd = 1, nbnd
DO ibnd = 1, nbnd
!
do jh = 1, nh(nt)
DO jh = 1, nh(nt)
!
jkb = ijkb0 + jh
!
do ih = 1, nh(nt)
DO ih = 1, nh(nt)
!
ikb = ijkb0 + ih
becp2(ikb, ibnd) = becp2(ikb, ibnd) + &
d_deeq(ih,jh,na,1) * becp1_c(jkb,ibnd,ik)
!
enddo
ENDDO
!
enddo
ENDDO
!
enddo
ENDDO
!
ijkb0 = ijkb0 + nh(nt)
!
endif
ENDIF
!
enddo
ENDDO
!
enddo
ENDDO
!
!evc1_new(ik) = evc1_new(ik) + vkb*becp2(ik)
call zgemm( 'N', 'N', npw_k(ik), nbnd, nkb, (1.d0,0.d0), vkb, &
CALL zgemm( 'N', 'N', npw_k(ik), nbnd, nkb, (1.d0,0.d0), vkb, &
npwx, becp2, nkb, (1.d0,0.d0), evc1_new(:,:,ik), npwx )
!
enddo
ENDDO
!
endif
ENDIF
!
endif
ENDIF
!
! Call h_psi on evc1
! h_psi uses arrays igk and npw, so restore those
!
do ik=1,nks
DO ik=1,nks
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!
do ig=1,npw_k(ik)
DO ig=1,npw_k(ik)
!
g2kin(ig)=((xk(1,ik)+g(1,igk_k(ig,ik)))**2 &
+(xk(2,ik)+g(2,igk_k(ig,ik)))**2 &
+(xk(3,ik)+g(3,igk_k(ig,ik)))**2)*tpiba2
!
enddo
ENDDO
!
igk(:)=igk_k(:,ik)
!
call h_psi(npwx,npw_k(ik),nbnd,evc1(1,1,ik),sevc1_new(1,1,ik))
CALL h_psi(npwx,npw_k(ik),nbnd,evc1(1,1,ik),sevc1_new(1,1,ik))
!
call s_psi(npwx,npw_k(ik),nbnd,evc1(1,1,ik),spsi1)
CALL s_psi(npwx,npw_k(ik),nbnd,evc1(1,1,ik),spsi1)
!
! Subtract the eigenvalues
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
do ig=1,npw_k(ik)
DO ig=1,npw_k(ik)
!
sevc1_new(ig,ibnd,ik)=sevc1_new(ig,ibnd,ik) &
-cmplx(et(ibnd,ik),0.0d0,dp)*spsi1(ig,ibnd)
!
enddo
ENDDO
!
enddo
ENDDO
!
enddo ! end k loop
ENDDO ! end k loop
!
if( nkb > 0 .and. okvan ) deallocate(becp2)
IF( nkb > 0 .and. okvan ) DEALLOCATE(becp2)
!
return
end subroutine lr_apply_liouvillian_k
RETURN
END SUBROUTINE lr_apply_liouvillian_k
!
end subroutine lr_apply_liouvillian
END SUBROUTINE lr_apply_liouvillian
!-----------------------------------------------------------------------

374
TDDFPT/src/lr_calc_dens.f90
View File

@ -1,5 +1,5 @@
!-----------------------------------------------------------------------
subroutine lr_calc_dens( evc1, response_calc )
SUBROUTINE lr_calc_dens( evc1, response_calc )
!---------------------------------------------------------------------
! ... calculates response charge density from linear response
! ... orbitals and ground state orbitals
@ -13,70 +13,70 @@ subroutine lr_calc_dens( evc1, response_calc )
#include "f_defs.h"
!
use ions_base, only : ityp,nat,ntyp=>nsp
use cell_base, only : omega
use ener, only : ef
use gvecs, only : nls,nlsm,doublegrid
use grid_dimensions, only : nrxx,nr1,nr2,nr3
use fft_base, only : dffts
use fft_interfaces, only : invfft
use io_global, only : stdout
use kinds, only : dp
use klist, only : nks,xk,wk
use lr_variables, only : evc0,revc0,rho_1,lr_verbosity, &
USE ions_base, ONLY : ityp,nat,ntyp=>nsp
USE cell_base, ONLY : omega
USE ener, ONLY : ef
USE gvecs, ONLY : nls,nlsm,doublegrid
USE grid_dimensions, ONLY : nrxx,nr1,nr2,nr3
USE fft_base, ONLY : dffts
USE fft_interfaces, ONLY : invfft
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE klist, ONLY : nks,xk,wk
USE lr_variables, ONLY : evc0,revc0,rho_1,lr_verbosity, &
charge_response, itermax,&
cube_save, rho_1_tot,rho_1_tot_im, &
LR_iteration, LR_polarization, &
project,evc0_virt,F,nbnd_total,n_ipol, becp1_virt
use lsda_mod, only : current_spin, isk
use wavefunctions_module, only : psic
use wvfct, only : nbnd,et,wg,npwx,npw
use control_flags, only : gamma_only
use uspp, only : vkb,nkb,okvan,qq,becsum
use uspp_param, only : upf, nh
USE lsda_mod, ONLY : current_spin, isk
USE wavefunctions_module, ONLY : psic
USE wvfct, ONLY : nbnd,et,wg,npwx,npw
USE control_flags, ONLY : gamma_only
USE uspp, ONLY : vkb,nkb,okvan,qq,becsum
USE uspp_param, ONLY : upf, nh
USE io_global, ONLY : ionode, stdout
use io_files, only : tmp_dir, prefix
use mp, only : mp_sum
use mp_global, ONLY : inter_pool_comm, intra_pool_comm,nproc
use realus, only : igk_k,npw_k,addusdens_r
use charg_resp, only : w_T, lr_dump_rho_tot_cube,&
USE io_files, ONLY : tmp_dir, prefix
USE mp, ONLY : mp_sum
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm,nproc
USE realus, ONLY : igk_k,npw_k,addusdens_r
USE charg_resp, ONLY : w_T, lr_dump_rho_tot_cube,&
lr_dump_rho_tot_xyzd, &
lr_dump_rho_tot_xcrys,&
resonance_condition,epsil
USE noncollin_module, ONLY : nspin_mag
use control_flags, only : tqr
use becmod, only : becp
USE control_flags, ONLY : tqr
USE becmod, ONLY : becp
!
implicit none
IMPLICIT NONE
!
character(len=6), external :: int_to_char
CHARACTER(len=6), EXTERNAL :: int_to_char
!
complex(kind=dp), intent(in) :: evc1(npwx,nbnd,nks)
logical, intent(in) :: response_calc
COMPLEX(kind=dp), INTENT(in) :: evc1(npwx,nbnd,nks)
LOGICAL, INTENT(in) :: response_calc
!
! functions
real(kind=dp) :: ddot
!
! local variables
integer :: ir,ik,ibnd,jbnd,ig,ijkb0,np,na,ijh,ih,jh,ikb,jkb,ispin
integer :: i, j, k, l
INTEGER :: ir,ik,ibnd,jbnd,ig,ijkb0,np,na,ijh,ih,jh,ikb,jkb,ispin
INTEGER :: i, j, k, l
real(kind=dp) :: w1,w2,scal
real(kind=dp) :: rho_sum!,weight
real(kind=dp), allocatable :: rho_sum_resp_x(:),rho_sum_resp_y(:),rho_sum_resp_z(:) ! These are temporary buffers for response cha
real(kind=dp), ALLOCATABLE :: rho_sum_resp_x(:),rho_sum_resp_y(:),rho_sum_resp_z(:) ! These are temporary buffers for response cha
!complex(kind=dp), external :: ZDOTC
!complex(kind=dp), allocatable :: spsi(:,:)
!
character(len=256) :: tempfile, filename
CHARACTER(len=256) :: tempfile, filename
!
!OBM DEBUG
complex(kind=dp),external :: lr_dot
COMPLEX(kind=dp),EXTERNAL :: lr_dot
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_calc_dens>")')
endif
ENDIF
!
call start_clock('lr_calc_dens')
CALL start_clock('lr_calc_dens')
!
!allocate(spsi(npwx,nbnd))
!spsi(:,:)=(0.0d0,0.0d0)
@ -85,77 +85,77 @@ subroutine lr_calc_dens( evc1, response_calc )
psic(:)=(0.0d0,0.0d0)
rho_1(:,:)=0.0d0
!
if(gamma_only) then
call lr_calc_dens_gamma()
else
call lr_calc_dens_k()
endif
IF(gamma_only) THEN
CALL lr_calc_dens_gamma()
ELSE
CALL lr_calc_dens_k()
ENDIF
!print *, "rho_1 after lr_calc_dens calculates",SUM(rho_1)
!print *, "norm of evc1 after lr_calc_dens calculates", lr_dot(evc1(1,1,1),evc1(1,1,1))
!
! ... If a double grid is used, interpolate onto the fine grid
!
if ( doublegrid ) call interpolate(rho_1,rho_1,1)
IF ( doublegrid ) CALL interpolate(rho_1,rho_1,1)
!
! ... Here we add the Ultrasoft contribution to the charge
!
!IF ( okvan ) CALL lr_addusdens(rho_1)
!print *, "rho_1 before addusdens",SUM(rho_1)
!call start_clock('lrcd_usdens') !TQR makes a huge gain here
if(okvan) then
if (tqr) then
IF(okvan) THEN
IF (tqr) THEN
CALL addusdens_r(rho_1,.false.)
else
ELSE
CALL addusdens(rho_1)
endif
endif
ENDIF
ENDIF
DEALLOCATE ( psic )
!call stop_clock('lrcd_usdens')
!
!print *, "rho_1 after addusdens",SUM(rho_1)
#ifdef __PARA
!call poolreduce(nrxx,rho_1)
call mp_sum(rho_1, inter_pool_comm)
CALL mp_sum(rho_1, inter_pool_comm)
#endif
!
! check response charge density sums to 0
!call start_clock('lrcd_sp') !Minimal lag, no need to improve
if (lr_verbosity > 0) then
IF (lr_verbosity > 0) THEN
do ispin = 1, nspin_mag
DO ispin = 1, nspin_mag
rho_sum=0.0d0
rho_sum=SUM(rho_1(:,ispin))
rho_sum=sum(rho_1(:,ispin))
!
#ifdef __PARA
call mp_sum(rho_sum, intra_pool_comm )
CALL mp_sum(rho_sum, intra_pool_comm )
#endif
!
rho_sum=rho_sum*omega/(nr1*nr2*nr3)
!
if(abs(rho_sum)>1.0d-12) then
if (tqr) then
write(stdout,'(5X, "lr_calc_dens: Charge drift due to real space implementation = " ,1X,e12.5)')&
IF(abs(rho_sum)>1.0d-12) THEN
IF (tqr) THEN
WRITE(stdout,'(5X, "lr_calc_dens: Charge drift due to real space implementation = " ,1X,e12.5)')&
rho_sum
!seems useless
!rho_sum=rho_sum/(1.0D0*nrxxs)
!rho_1(:,ispin)=rho_1(:,ispin)-rho_sum
else
write(stdout,'(5X,"lr_calc_dens: ****** response charge density does not sum to zero")')
ELSE
WRITE(stdout,'(5X,"lr_calc_dens: ****** response charge density does not sum to zero")')
!
write(stdout,'(5X,"lr_calc_dens: ****** response charge density =",1X,e12.5)')&
WRITE(stdout,'(5X,"lr_calc_dens: ****** response charge density =",1X,e12.5)')&
rho_sum
!
write(stdout,'(5X,"lr_calc_dens: ****** response charge density, US part =",1X,e12.5)')&
WRITE(stdout,'(5X,"lr_calc_dens: ****** response charge density, US part =",1X,e12.5)')&
scal
! call errore(' lr_calc_dens ','Linear response charge density '// &
! & 'does not sum to zero',1)
endif
endif
enddo
ENDIF
ENDIF
ENDDO
!
endif
IF (charge_response == 2 .and. LR_iteration /=0) then
ENDIF
IF (charge_response == 2 .and. LR_iteration /=0) THEN
!
ALLOCATE( rho_sum_resp_x( nr1 ) )
ALLOCATE( rho_sum_resp_y( nr2 ) )
@ -175,60 +175,60 @@ endif
rho_sum_resp_y(j)=rho_sum_resp_y(j)+rho_1(ir,1)
rho_sum_resp_z(k)=rho_sum_resp_z(k)+rho_1(ir,1)
!
END DO
ENDDO
!
#ifdef __PARA
call mp_sum(rho_sum_resp_x, intra_pool_comm)
call mp_sum(rho_sum_resp_y, intra_pool_comm)
call mp_sum(rho_sum_resp_z, intra_pool_comm)
if (ionode) then
CALL mp_sum(rho_sum_resp_x, intra_pool_comm)
CALL mp_sum(rho_sum_resp_y, intra_pool_comm)
CALL mp_sum(rho_sum_resp_z, intra_pool_comm)
IF (ionode) THEN
#endif
write(stdout,'(5X,"Dumping plane sums of densities for iteration ",I4)') LR_iteration
WRITE(stdout,'(5X,"Dumping plane sums of densities for iteration ",I4)') LR_iteration
!
filename = trim(prefix) // ".density_x"
tempfile = trim(tmp_dir) // trim(filename)
!
open (158, file = tempfile, form = 'formatted', status = 'unknown', position = 'append')
OPEN (158, file = tempfile, form = 'formatted', status = 'unknown', position = 'append')
!
do i=1,nr1
write(158,*) rho_sum_resp_x(i)
end do
DO i=1,nr1
WRITE(158,*) rho_sum_resp_x(i)
ENDDO
!
close(158)
CLOSE(158)
!
filename = trim(prefix) // ".density_y"
tempfile = trim(tmp_dir) // trim(filename)
!
open (158, file = tempfile, form = 'formatted', status = 'unknown', position = 'append')
OPEN (158, file = tempfile, form = 'formatted', status = 'unknown', position = 'append')
!
do i=1,nr2
write(158,*) rho_sum_resp_y(i)
end do
DO i=1,nr2
WRITE(158,*) rho_sum_resp_y(i)
ENDDO
!
close(158)
CLOSE(158)
!
filename = trim(prefix) // ".density_z"
tempfile = trim(tmp_dir) // trim(filename)
!
open (158, file = tempfile, form = 'formatted', status = 'unknown', position = 'append')
OPEN (158, file = tempfile, form = 'formatted', status = 'unknown', position = 'append')
!
do i=1,nr3
write(158,*) rho_sum_resp_z(i)
end do
DO i=1,nr3
WRITE(158,*) rho_sum_resp_z(i)
ENDDO
!
close(158)
CLOSE(158)
!
#ifdef __PARA
end if
ENDIF
#endif
!
DEALLOCATE( rho_sum_resp_x )
DEALLOCATE( rho_sum_resp_y )
DEALLOCATE( rho_sum_resp_z )
!
END IF
IF (charge_response == 1 .and. response_calc) then
if (LR_iteration < itermax) WRITE(stdout,'(5x,"Calculating total response charge density")')
ENDIF
IF (charge_response == 1 .and. response_calc) THEN
IF (LR_iteration < itermax) WRITE(stdout,'(5x,"Calculating total response charge density")')
! the charge response, it is actually equivalent to an element of
! V^T . phi_v where V^T is the is the transpose of the Krylov subspace generated
! by the Lanczos algorithm. The total charge density can be written
@ -243,25 +243,25 @@ endif
!
!print *,"1"
!print *,"weight",(-1.0d0*AIMAG(w_T(LR_iteration)))
if (resonance_condition) then
IF (resonance_condition) THEN
!singular matrix, the broadening term dominates, phi' has strong imaginary component
!DO ir=1,nrxx
! rho_1_tot_im(ir,:)=rho_1_tot_im(ir,:)+cmplx(rho_1(ir,:),0.0d0,dp)*w_T(LR_iteration)
!enddo
call zaxpy(nrxx, w_T(LR_iteration),cmplx(rho_1(:,1),0.0d0,dp),1,rho_1_tot_im(:,1),1) !spin not implemented
else
CALL zaxpy(nrxx, w_T(LR_iteration),cmplx(rho_1(:,1),0.0d0,dp),1,rho_1_tot_im(:,1),1) !spin not implemented
ELSE
!not at resonance, the imaginary part is neglected ,these are the non-absorbing oscillations
!DO ir=1,nrxx
! rho_1_tot(ir,:)=rho_1_tot(ir,:)+rho_1(ir,:)*dble(w_T(LR_iteration))
!enddo
call daxpy(nrxx, dble(w_T(LR_iteration)),rho_1(:,1),1,rho_1_tot(:,1),1) !spin not implemented
endif
If (lr_verbosity > 9) THEN
if (LR_iteration == 2) then
call lr_dump_rho_tot_cube(rho_1(:,1),"first-rho1")
endif
if (LR_iteration == itermax .or. LR_iteration == itermax-1) call lr_dump_rho_tot_cube(rho_1(:,1),"last--rho1")
endif
CALL daxpy(nrxx, dble(w_T(LR_iteration)),rho_1(:,1),1,rho_1_tot(:,1),1) !spin not implemented
ENDIF
IF (lr_verbosity > 9) THEN
IF (LR_iteration == 2) THEN
CALL lr_dump_rho_tot_cube(rho_1(:,1),"first-rho1")
ENDIF
IF (LR_iteration == itermax .or. LR_iteration == itermax-1) CALL lr_dump_rho_tot_cube(rho_1(:,1),"last--rho1")
ENDIF
!print *,"2"
!
!
@ -270,17 +270,17 @@ endif
!
!deallocate(spsi)
!
call stop_clock('lr_calc_dens')
CALL stop_clock('lr_calc_dens')
!
!call stop_clock('lrcd_sp')
return
RETURN
!
contains
CONTAINS
!
subroutine lr_calc_dens_gamma
SUBROUTINE lr_calc_dens_gamma
!
use becmod, only : bec_type, becp, calbec
use lr_variables, only : becp1 !,real_space
USE becmod, ONLY : bec_type, becp, calbec
USE lr_variables, ONLY : becp1 !,real_space
!use real_beta, only : ccalbecr_gamma, fft_orbital_gamma
USE io_global, ONLY : stdout
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
@ -289,16 +289,16 @@ contains
!
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc1(:,:,1),ibnd,nbnd)
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc1(:,:,1),ibnd,nbnd)
!
w1=wg(ibnd,1)/omega
!
if(ibnd<nbnd) then
IF(ibnd<nbnd) THEN
w2=wg(ibnd+1,1)/omega
else
ELSE
w2=w1
endif
ENDIF
!call start_clock('lrcd-lp1')
! OBM:
! (n'(r,w)=2*sum_v (psi_v(r) . q_v(r,w))
@ -310,56 +310,56 @@ contains
! charge density can be calculated. This is in no way the final
! response charge density.
! the loop is over real space points.
do ir=1,dffts%nnr
DO ir=1,dffts%nnr
rho_1(ir,1)=rho_1(ir,1) &
+2.0d0*(w1*real(revc0(ir,ibnd,1),dp)*real(psic(ir),dp)&
+w2*aimag(revc0(ir,ibnd,1))*aimag(psic(ir)))
enddo
ENDDO
!
!call stop_clock('lrcd-lp1')
! OBM - psic now contains the response functions at
! real space, eagerly putting all the real space stuff at this point.
! notice that betapointlist() is called in lr_readin at the very start
IF ( real_space_debug > 6 .and. okvan) then
IF ( real_space_debug > 6 .and. okvan) THEN
! The rbecp term
call calbec_rs_gamma(ibnd,nbnd,becp%r)
endif
CALL calbec_rs_gamma(ibnd,nbnd,becp%r)
ENDIF
! End of real space stuff
enddo
ENDDO
!
! ... If we have a US pseudopotential we compute here the becsum term
! This corresponds to the right hand side of the formula (36) in Ultrasoft paper
! be careful about calling lr_calc_dens, as it modifies this globally
!call start_clock('lrcd-us')
IF ( okvan ) then
IF ( okvan ) THEN
!
scal = 0.0d0
becsum(:,:,:) = 0.0d0
!
IF ( real_space_debug <= 6) then !in real space, the value is calculated above
IF ( real_space_debug <= 6) THEN !in real space, the value is calculated above
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,evc1,npwx,rbecp,nkb)
call calbec(npw_k(1), vkb, evc1(:,:,1), becp)
endif
CALL calbec(npw_k(1), vkb, evc1(:,:,1), becp)
ENDIF
!
call start_clock( 'becsum' )
CALL start_clock( 'becsum' )
!
do ibnd = 1, nbnd
DO ibnd = 1, nbnd
scal = 0.0d0
!
w1 = wg(ibnd,1)
ijkb0 = 0
!
do np = 1, ntyp
DO np = 1, ntyp
!
if ( upf(np)%tvanp ) then
IF ( upf(np)%tvanp ) THEN
!
do na = 1, nat
DO na = 1, nat
!
if ( ityp(na) == np ) then
IF ( ityp(na) == np ) THEN
!
ijh = 1
!
do ih = 1, nh(np)
DO ih = 1, nh(np)
!
ikb = ijkb0 + ih
!
@ -370,7 +370,7 @@ contains
!
ijh = ijh + 1
!
do jh = ( ih + 1 ), nh(np)
DO jh = ( ih + 1 ), nh(np)
!
jkb = ijkb0 + jh
!
@ -383,102 +383,102 @@ contains
!
ijh = ijh + 1
!
end do
ENDDO
!
end do
ENDDO
!
ijkb0 = ijkb0 + nh(np)
!
end if
ENDIF
!
end do
ENDDO
!
else
ELSE
!
do na = 1, nat
DO na = 1, nat
!
if ( ityp(na) == np ) ijkb0 = ijkb0 + nh(np)
IF ( ityp(na) == np ) ijkb0 = ijkb0 + nh(np)
!
end do
ENDDO
!
end if
ENDIF
!
end do
ENDDO
!
! OBM debug
!write(stdout,'(5X,"lr_calc_dens: ibnd,scal=",1X,i3,1X,e12.5)')&
! ibnd,scal
end do
ENDDO
!
call stop_clock( 'becsum' )
CALL stop_clock( 'becsum' )
!
endif
ENDIF
!call stop_clock('lrcd-us')
!
return
RETURN
!
end subroutine lr_calc_dens_gamma
END SUBROUTINE lr_calc_dens_gamma
!-----------------------------------------------------------------------
subroutine lr_calc_dens_k
SUBROUTINE lr_calc_dens_k
!
use becmod, only : bec_type, becp, calbec
use lr_variables, only : becp1_c
USE becmod, ONLY : bec_type, becp, calbec
USE lr_variables, ONLY : becp1_c
!
do ik=1,nks
do ibnd=1,nbnd
DO ik=1,nks
DO ibnd=1,nbnd
psic(:)=(0.0d0,0.0d0)
do ig=1,npw_k(ik)
DO ig=1,npw_k(ik)
psic(nls(igk_k(ig,ik)))=evc1(ig,ibnd,ik)
enddo
ENDDO
!
CALL invfft ('Wave', psic, dffts)
!
w1=wg(ibnd,ik)/omega
!
! loop over real space points
do ir=1,dffts%nnr
DO ir=1,dffts%nnr
rho_1(ir,:)=rho_1(ir,:) &
+2.0d0*w1*real(conjg(revc0(ir,ibnd,ik))*psic(ir),dp)
enddo
ENDDO
!
enddo
enddo
ENDDO
ENDDO
!
! ... If we have a US pseudopotential we compute here the becsum term
!
IF ( okvan ) then
IF ( okvan ) THEN
!
do ik =1,nks
DO ik =1,nks
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!
scal = 0.0d0
becsum(:,:,:) = 0.0d0
!
IF ( nkb > 0 .and. okvan ) then
IF ( nkb > 0 .and. okvan ) THEN
! call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp,vkb,evc1)
call calbec(npw_k(ik),vkb,evc1(:,:,ik),becp)
endif
CALL calbec(npw_k(ik),vkb,evc1(:,:,ik),becp)
ENDIF
!
call start_clock( 'becsum' )
CALL start_clock( 'becsum' )
!
do ibnd = 1, nbnd
DO ibnd = 1, nbnd
scal = 0.0d0
!
w1 = wg(ibnd,ik)
ijkb0 = 0
!
do np = 1, ntyp
DO np = 1, ntyp
!
if ( upf(np)%tvanp ) then
IF ( upf(np)%tvanp ) THEN
!
do na = 1, nat
DO na = 1, nat
!
if ( ityp(na) == np ) then
IF ( ityp(na) == np ) THEN
!
ijh = 1
!
do ih = 1, nh(np)
DO ih = 1, nh(np)
!
ikb = ijkb0 + ih
!
@ -489,7 +489,7 @@ contains
!
ijh = ijh + 1
!
do jh = ( ih + 1 ), nh(np)
DO jh = ( ih + 1 ), nh(np)
!
jkb = ijkb0 + jh
!
@ -502,41 +502,41 @@ contains
!
ijh = ijh + 1
!
end do
ENDDO
!
end do
ENDDO
!
ijkb0 = ijkb0 + nh(np)
!
end if
ENDIF
!
end do
ENDDO
!
else
ELSE
!
do na = 1, nat
DO na = 1, nat
!
if ( ityp(na) == np ) ijkb0 = ijkb0 + nh(np)
IF ( ityp(na) == np ) ijkb0 = ijkb0 + nh(np)
!
end do
ENDDO
!
end if
ENDIF
!
end do
ENDDO
!
! write(stdout,'(5X,"lr_calc_dens: ibnd,scal=",1X,i3,1X,e12.5)')&
! ibnd,scal
end do
call stop_clock( 'becsum' )
ENDDO
CALL stop_clock( 'becsum' )
!
enddo
ENDDO
!
endif
ENDIF
!
return
RETURN
!
end subroutine lr_calc_dens_k
END SUBROUTINE lr_calc_dens_k
!-------------------------------------------------------------------------------
!-----------------------------------------------------------------------
end subroutine lr_calc_dens
END SUBROUTINE lr_calc_dens
!-----------------------------------------------------------------------

214
TDDFPT/src/lr_cgsolve_all.f90
View File

@ -11,10 +11,10 @@
#include "f_defs.h"
!
!----------------------------------------------------------------------
subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
SUBROUTINE lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
ndmx, ndim, ethr, ik, kter, conv_root, anorm, nbnd, npol)
!----------------------------------------------------------------------
! Modified by Osman Baris Malcioglu in 2009
! Modified by Osman Baris Malcioglu in 2009
!
! iterative solution of the linear system:
!
@ -60,7 +60,7 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
! revised (extensively) 6 Apr 1997 by A. Dal Corso & F. Mauri
! revised (to reduce memory) 29 May 2004 by S. de Gironcoli
!
USE kinds, only : DP
USE kinds, ONLY : DP
USE mp_global, ONLY: intra_pool_comm
USE mp, ONLY: mp_sum
USE control_flags, ONLY: gamma_only
@ -68,11 +68,11 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
USE lr_variables, ONLY: lr_verbosity
USE gvect, ONLY: gstart
implicit none
IMPLICIT NONE
!
! first the I/O variables
!
integer :: ndmx, & ! input: the maximum dimension of the vectors
INTEGER :: ndmx, & ! input: the maximum dimension of the vectors
ndim, & ! input: the actual dimension of the vectors
kter, & ! output: counter on iterations
nbnd, & ! input: the number of bands
@ -85,36 +85,36 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
h_diag(ndmx*npol,nbnd), & ! input: an estimate of ( H - \epsilon )
ethr ! input: the required precision
complex(DP) :: &
COMPLEX(DP) :: &
dpsi (ndmx*npol, nbnd), & ! output: the solution of the linear syst
d0psi (ndmx*npol, nbnd) ! input: the known term
logical :: conv_root ! output: if true the root is converged
external h_psi, & ! input: the routine computing h_psi
LOGICAL :: conv_root ! output: if true the root is converged
EXTERNAL h_psi, & ! input: the routine computing h_psi
cg_psi ! input: the routine computing cg_psi
!
! here the local variables
!
integer, parameter :: maxter = 200
INTEGER, PARAMETER :: maxter = 200
! the maximum number of iterations
integer :: iter, ibnd, lbnd
INTEGER :: iter, ibnd, lbnd
! counters on iteration, bands
integer , allocatable :: conv (:)
INTEGER , ALLOCATABLE :: conv (:)
! if 1 the root is converged
complex(DP), allocatable :: g (:,:), t (:,:), h (:,:), hold (:,:)
COMPLEX(DP), ALLOCATABLE :: g (:,:), t (:,:), h (:,:), hold (:,:)
! the gradient of psi
! the preconditioned gradient
! the delta gradient
! the conjugate gradient
! work space
complex(DP) :: dcgamma, dclambda
COMPLEX(DP) :: dcgamma, dclambda
! the ratio between rho
! step length
complex(DP), external :: zdotc
real(kind=dp), external :: ddot
COMPLEX(DP), EXTERNAL :: zdotc
real(kind=dp), EXTERNAL :: ddot
! the scalar product
real(DP), allocatable :: rho (:), rhoold (:), eu (:), a(:), c(:)
real(DP), ALLOCATABLE :: rho (:), rhoold (:), eu (:), a(:), c(:)
! the residue
! auxiliary for h_diag
real(DP) :: kter_eff
@ -123,10 +123,10 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
!
!obm debug
!real(DP) :: obm_debug
call start_clock ('cgsolve')
If (lr_verbosity > 5) WRITE(stdout,'("<lr_cgsolve_all>")')
CALL start_clock ('cgsolve')
IF (lr_verbosity > 5) WRITE(stdout,'("<lr_cgsolve_all>")')
!OBM debug
! obm_debug=0
! do ibnd=1,nbnd
@ -138,39 +138,39 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
!
!!obm_debug
allocate ( g(ndmx*npol,nbnd), t(ndmx*npol,nbnd), h(ndmx*npol,nbnd), &
hold(ndmx*npol ,nbnd) )
allocate (a(nbnd), c(nbnd))
allocate (conv ( nbnd))
allocate (rho(nbnd),rhoold(nbnd))
allocate (eu ( nbnd))
ALLOCATE ( g(ndmx*npol,nbnd), t(ndmx*npol,nbnd), h(ndmx*npol,nbnd), &
hold(ndmx*npol ,nbnd) )
ALLOCATE (a(nbnd), c(nbnd))
ALLOCATE (conv ( nbnd))
ALLOCATE (rho(nbnd),rhoold(nbnd))
ALLOCATE (eu ( nbnd))
! WRITE( stdout,*) g,t,h,hold
kter_eff = 0.d0
do ibnd = 1, nbnd
DO ibnd = 1, nbnd
conv (ibnd) = 0
enddo
ENDDO
g=(0.d0,0.d0)
t=(0.d0,0.d0)
h=(0.d0,0.d0)
hold=(0.d0,0.d0)
do iter = 1, maxter
DO iter = 1, maxter
!
! compute the gradient. can reuse information from previous step
!
if (iter == 1) then
call h_psi (ndim, dpsi, g, e, ik, nbnd)
do ibnd = 1, nbnd
call zaxpy (ndim, (-1.d0,0.d0), d0psi(1,ibnd), 1, g(1,ibnd), 1)
enddo
IF (iter == 1) THEN
CALL h_psi (ndim, dpsi, g, e, ik, nbnd)
DO ibnd = 1, nbnd
CALL zaxpy (ndim, (-1.d0,0.d0), d0psi(1,ibnd), 1, g(1,ibnd), 1)
ENDDO
IF (npol==2) THEN
do ibnd = 1, nbnd
call zaxpy (ndim, (-1.d0,0.d0), d0psi(ndmx+1,ibnd), 1, &
DO ibnd = 1, nbnd
CALL zaxpy (ndim, (-1.d0,0.d0), d0psi(ndmx+1,ibnd), 1, &
g(ndmx+1,ibnd), 1)
enddo
END IF
ENDDO
ENDIF
!print *, "first iteration"
endif
ENDIF
!OBM debug
! obm_debug=0
! do ibnd=1,nbnd
@ -178,7 +178,7 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
! obm_debug=obm_debug+ZDOTC(ndim,dpsi(:,ibnd),1,dpsi(:,ibnd),1)
! !
! enddo
! print *, "cq_solve_all dpsi", obm_debug
! print *, "cq_solve_all dpsi", obm_debug
! obm_debug=0
! do ibnd=1,nbnd
! !
@ -192,124 +192,124 @@ subroutine lr_cgsolve_all (h_psi, cg_psi, e, d0psi, dpsi, h_diag, &
! compute preconditioned residual vector and convergence check
!
lbnd = 0
do ibnd = 1, nbnd
if (conv (ibnd) .eq.0) then
DO ibnd = 1, nbnd
IF (conv (ibnd) ==0) THEN
lbnd = lbnd+1
call zcopy (ndmx*npol, g (1, ibnd), 1, h (1, ibnd), 1)
call cg_psi(ndmx, ndim, 1, h(1,ibnd), h_diag(1,ibnd) )
if (gamma_only) then
rho(lbnd)=2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,g(1,ibnd),1)
if(gstart==2) rho(lbnd)=rho(lbnd)-dble(h(1,ibnd))*dble(g(1,ibnd))
else
CALL zcopy (ndmx*npol, g (1, ibnd), 1, h (1, ibnd), 1)
CALL cg_psi(ndmx, ndim, 1, h(1,ibnd), h_diag(1,ibnd) )
IF (gamma_only) THEN
rho(lbnd)=2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,g(1,ibnd),1)
IF(gstart==2) rho(lbnd)=rho(lbnd)-dble(h(1,ibnd))*dble(g(1,ibnd))
ELSE
rho(lbnd) = zdotc (ndmx*npol, h(1,ibnd), 1, g(1,ibnd), 1)
endif
endif
enddo
kter_eff = kter_eff + DBLE (lbnd) / DBLE (nbnd)
ENDIF
ENDIF
ENDDO
kter_eff = kter_eff + dble (lbnd) / dble (nbnd)
#ifdef __PARA
call mp_sum( rho(1:lbnd) , intra_pool_comm )
CALL mp_sum( rho(1:lbnd) , intra_pool_comm )
#endif
do ibnd = nbnd, 1, -1
if (conv(ibnd).eq.0) then
DO ibnd = nbnd, 1, -1
IF (conv(ibnd)==0) THEN
rho(ibnd)=rho(lbnd)
lbnd = lbnd -1
anorm = sqrt (rho (ibnd) )
! write(6,*) ibnd, anorm
if (anorm.lt.ethr) conv (ibnd) = 1
if (lr_verbosity > 5 ) &
write(stdout,'(5X,"lr_cgsolve_all: iter,ibnd,anorm,rho=",1X,i3,1X,i3,1X,e12.5,1X,e12.5)')&
iter,ibnd,anorm,rho(ibnd)
endif
enddo
IF (anorm<ethr) conv (ibnd) = 1
IF (lr_verbosity > 5 ) &
WRITE(stdout,'(5X,"lr_cgsolve_all: iter,ibnd,anorm,rho=",1X,i3,1X,i3,1X,e12.5,1X,e12.5)')&
iter,ibnd,anorm,rho(ibnd)
ENDIF
ENDDO
!
conv_root = .true.
do ibnd = 1, nbnd
conv_root = conv_root.and. (conv (ibnd) .eq.1)
enddo
if (conv_root) goto 100
DO ibnd = 1, nbnd
conv_root = conv_root.and. (conv (ibnd) ==1)
ENDDO
IF (conv_root) GOTO 100
!
! compute the step direction h. Conjugate it to previous step
!
lbnd = 0
do ibnd = 1, nbnd
if (conv (ibnd) .eq.0) then
DO ibnd = 1, nbnd
IF (conv (ibnd) ==0) THEN
!
! change sign to h
! change sign to h
!
call dscal (2 * ndmx * npol, - 1.d0, h (1, ibnd), 1)
if (iter.ne.1) then
CALL dscal (2 * ndmx * npol, - 1.d0, h (1, ibnd), 1)
IF (iter/=1) THEN
dcgamma = rho (ibnd) / rhoold (ibnd)
call zaxpy (ndmx*npol, dcgamma, hold (1, ibnd), 1, h (1, ibnd), 1)
endif
CALL zaxpy (ndmx*npol, dcgamma, hold (1, ibnd), 1, h (1, ibnd), 1)
ENDIF
!
! here hold is used as auxiliary vector in order to efficiently compute t = A*h
! it is later set to the current (becoming old) value of h
! it is later set to the current (becoming old) value of h
!
lbnd = lbnd+1
call zcopy (ndmx*npol, h (1, ibnd), 1, hold (1, lbnd), 1)
CALL zcopy (ndmx*npol, h (1, ibnd), 1, hold (1, lbnd), 1)
eu (lbnd) = e (ibnd)
endif
enddo
ENDIF
ENDDO
!
! compute t = A*h
!
call h_psi (ndim, hold, t, eu, ik, lbnd)
CALL h_psi (ndim, hold, t, eu, ik, lbnd)
!print *, hold(1:5,lbnd)
!
! compute the coefficients a and c for the line minimization
! compute step length lambda
lbnd=0
do ibnd = 1, nbnd
if (conv (ibnd) .eq.0) then
DO ibnd = 1, nbnd
IF (conv (ibnd) ==0) THEN
lbnd=lbnd+1
if (gamma_only) then
IF (gamma_only) THEN
a(lbnd) = 2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,g(1,ibnd),1)
c(lbnd) = 2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,t(1,lbnd),1)
if (gstart == 2) then
IF (gstart == 2) THEN
a(lbnd)=a(lbnd)-dble(h(1,ibnd))*dble(g(1,ibnd))
c(lbnd)=c(lbnd)-dble(h(1,ibnd))*dble(t(1,lbnd))
endif
else
ENDIF
ELSE
a(lbnd) = zdotc (ndmx*npol, h(1,ibnd), 1, g(1,ibnd), 1)
c(lbnd) = zdotc (ndmx*npol, h(1,ibnd), 1, t(1,lbnd), 1)
endif
end if
end do
ENDIF
ENDIF
ENDDO
#ifdef __PARA
call mp_sum( a(1:lbnd), intra_pool_comm )
call mp_sum( c(1:lbnd), intra_pool_comm )
CALL mp_sum( a(1:lbnd), intra_pool_comm )
CALL mp_sum( c(1:lbnd), intra_pool_comm )
#endif
lbnd=0
do ibnd = 1, nbnd
if (conv (ibnd) .eq.0) then
DO ibnd = 1, nbnd
IF (conv (ibnd) ==0) THEN
lbnd=lbnd+1
dclambda = CMPLX( - a(lbnd) / c(lbnd), 0.d0)
dclambda = cmplx( - a(lbnd) / c(lbnd), 0.d0)
!
! move to new position
!
call zaxpy (ndmx*npol, dclambda, h(1,ibnd), 1, dpsi(1,ibnd), 1)
CALL zaxpy (ndmx*npol, dclambda, h(1,ibnd), 1, dpsi(1,ibnd), 1)
!
! update to get the gradient
!
!g=g+lam
call zaxpy (ndmx*npol, dclambda, t(1,lbnd), 1, g(1,ibnd), 1)
CALL zaxpy (ndmx*npol, dclambda, t(1,lbnd), 1, g(1,ibnd), 1)
!
! save current (now old) h and rho for later use
!
call zcopy (ndmx*npol, h(1,ibnd), 1, hold(1,ibnd), 1)
!
CALL zcopy (ndmx*npol, h(1,ibnd), 1, hold(1,ibnd), 1)
rhoold (ibnd) = rho (ibnd)
endif
enddo
enddo
100 continue
ENDIF
ENDDO
ENDDO
100 CONTINUE
kter = kter_eff
deallocate (eu)
deallocate (rho, rhoold)
deallocate (conv)
deallocate (a,c)
deallocate (g, t, h, hold)
DEALLOCATE (eu)
DEALLOCATE (rho, rhoold)
DEALLOCATE (conv)
DEALLOCATE (a,c)
DEALLOCATE (g, t, h, hold)
call stop_clock ('cgsolve')
return
end subroutine lr_cgsolve_all
CALL stop_clock ('cgsolve')
RETURN
END SUBROUTINE lr_cgsolve_all

202
TDDFPT/src/lr_ch_psi_all.f90
View File

@ -7,7 +7,7 @@
!
!-----------------------------------------------------------------------
subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
SUBROUTINE lr_ch_psi_all (n, h, ah, e, ik, m)
!-----------------------------------------------------------------------
!
! This routine applies the operator ( H - \epsilon S + alpha_pv P_v)
@ -17,7 +17,7 @@ subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
!
#include "f_defs.h"
USE kinds, only : DP
USE kinds, ONLY : DP
USE wvfct, ONLY : npwx, nbnd
USE uspp, ONLY: nkb, vkb
USE noncollin_module, ONLY : noncolin, npol
@ -29,14 +29,14 @@ subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
USE mp_global, ONLY: intra_pool_comm
USE mp, ONLY: mp_sum
use control_flags, only : gamma_only
use wavefunctions_module, only : evc !evq is replaced by evc
!use lr_variables, only : lr_alpha_pv, nbnd_occ,
use lr_variables, only : lr_verbosity
use io_global, only : stdout
implicit none
USE control_flags, ONLY : gamma_only
USE wavefunctions_module, ONLY : evc !evq is replaced by evc
!use lr_variables, only : lr_alpha_pv, nbnd_occ,
USE lr_variables, ONLY : lr_verbosity
USE io_global, ONLY : stdout
IMPLICIT NONE
integer :: n, m, ik
INTEGER :: n, m, ik
! input: the dimension of h
! input: the number of bands
! input: the k point
@ -44,31 +44,31 @@ subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
real(DP) :: e (m)
! input: the eigenvalue
complex(DP) :: h (npwx*npol, m), ah (npwx*npol, m)
COMPLEX(DP) :: h (npwx*npol, m), ah (npwx*npol, m)
! input: the vector
! output: the operator applied to the vector
!
! local variables
!
integer :: ibnd, ikq, ig
INTEGER :: ibnd, ikq, ig
! counter on bands
! the point k+q
! counter on G vetors
complex(DP), allocatable :: hpsi (:,:), spsi (:,:)
COMPLEX(DP), ALLOCATABLE :: hpsi (:,:), spsi (:,:)
! scalar products
! the product of the Hamiltonian and h
! the product of the S matrix and h
!OBM debug
!real(DP) :: obm_debug
!complex(kind=dp), external :: ZDOTC
call start_clock ('ch_psi')
If (lr_verbosity > 5) WRITE(stdout,'("<lr_ch_psi_all>")')
allocate (hpsi( npwx*npol , m))
allocate (spsi( npwx*npol , m))
CALL start_clock ('ch_psi')
IF (lr_verbosity > 5) WRITE(stdout,'("<lr_ch_psi_all>")')
ALLOCATE (hpsi( npwx*npol , m))
ALLOCATE (spsi( npwx*npol , m))
hpsi (:,:) = (0.d0, 0.d0)
spsi (:,:) = (0.d0, 0.d0)
!
@ -83,7 +83,7 @@ subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
! print *, "lr_ch_psi_all h", obm_debug
!!obm_debug
!
call lr_h_psiq (npwx, n, m, h, hpsi, spsi)
CALL lr_h_psiq (npwx, n, m, h, hpsi, spsi)
!!OBM debug
! obm_debug=0
! do ibnd=1,m
@ -94,31 +94,31 @@ subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
! print *, "lr_ch_psi_all hpsi", obm_debug
!!obm_debug
call start_clock ('last')
CALL start_clock ('last')
!
! then we compute the operator H-epsilon S
!
ah=(0.d0,0.d0)
do ibnd = 1, m
do ig = 1, n
DO ibnd = 1, m
DO ig = 1, n
ah (ig, ibnd) = hpsi (ig, ibnd) - e (ibnd) * spsi (ig, ibnd)
enddo
enddo
ENDDO
ENDDO
IF (noncolin) THEN
do ibnd = 1, m
do ig = 1, n
DO ibnd = 1, m
DO ig = 1, n
ah (ig+npwx,ibnd)=hpsi(ig+npwx,ibnd)-e(ibnd)*spsi(ig+npwx,ibnd)
end do
end do
END IF
ENDDO
ENDDO
ENDIF
!
! Here we compute the projector in the valence band
!
if(gamma_only) then
call lr_ch_psi_all_gamma()
else
call lr_ch_psi_all_k()
endif
IF(gamma_only) THEN
CALL lr_ch_psi_all_gamma()
ELSE
CALL lr_ch_psi_all_k()
ENDIF
!!OBM debug
! obm_debug=0
! do ibnd=1,m
@ -128,132 +128,132 @@ subroutine lr_ch_psi_all (n, h, ah, e, ik, m)
! enddo
! print *, "lr_ch_psi_all ah", obm_debug
!!obm_debug
!
deallocate (spsi)
deallocate (hpsi)
call stop_clock ('last')
call stop_clock ('ch_psi')
return
contains
!
DEALLOCATE (spsi)
DEALLOCATE (hpsi)
CALL stop_clock ('last')
CALL stop_clock ('ch_psi')
RETURN
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!K-point part
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_ch_psi_all_k()
SUBROUTINE lr_ch_psi_all_k()
USE becmod, ONLY : becp, calbec
IMPLICIT NONE
complex(kind=dp), allocatable :: ps(:,:)
allocate (ps ( nbnd , m))
COMPLEX(kind=dp), ALLOCATABLE :: ps(:,:)
ALLOCATE (ps ( nbnd , m))
!ikq = ikqs(ik)
ps (:,:) = (0.d0, 0.d0)
IF (noncolin) THEN
call ZGEMM ('C', 'N', nbnd_occ (ik) , m, npwx*npol, (1.d0, 0.d0) , evc, &
CALL ZGEMM ('C', 'N', nbnd_occ (ik) , m, npwx*npol, (1.d0, 0.d0) , evc, &
npwx*npol, spsi, npwx*npol, (0.d0, 0.d0) , ps, nbnd)
ELSE
call ZGEMM ('C', 'N', nbnd_occ (ik) , m, n, (1.d0, 0.d0) , evc, &
CALL ZGEMM ('C', 'N', nbnd_occ (ik) , m, n, (1.d0, 0.d0) , evc, &
npwx, spsi, npwx, (0.d0, 0.d0) , ps, nbnd)
ENDIF
ps (:,:) = ps(:,:) * alpha_pv
#ifdef __PARA
call mp_sum ( ps, intra_pool_comm )
CALL mp_sum ( ps, intra_pool_comm )
#endif
hpsi (:,:) = (0.d0, 0.d0)
IF (noncolin) THEN
call ZGEMM ('N', 'N', npwx*npol, m, nbnd_occ (ik) , (1.d0, 0.d0) , evc, &
CALL ZGEMM ('N', 'N', npwx*npol, m, nbnd_occ (ik) , (1.d0, 0.d0) , evc, &
npwx*npol, ps, nbnd, (1.d0, 0.d0) , hpsi, npwx*npol)
ELSE
call ZGEMM ('N', 'N', n, m, nbnd_occ (ik) , (1.d0, 0.d0) , evc, &
CALL ZGEMM ('N', 'N', n, m, nbnd_occ (ik) , (1.d0, 0.d0) , evc, &
npwx, ps, nbnd, (1.d0, 0.d0) , hpsi, npwx)
END IF
ENDIF
spsi(:,:) = hpsi(:,:)
!
! And apply S again
!
call calbec (n, vkb, hpsi, becp, m)
call s_psi (npwx, n, m, hpsi, spsi)
do ibnd = 1, m
do ig = 1, n
CALL calbec (n, vkb, hpsi, becp, m)
CALL s_psi (npwx, n, m, hpsi, spsi)
DO ibnd = 1, m
DO ig = 1, n
ah (ig, ibnd) = ah (ig, ibnd) + spsi (ig, ibnd)
enddo
enddo
ENDDO
ENDDO
IF (noncolin) THEN
do ibnd = 1, m
do ig = 1, n
DO ibnd = 1, m
DO ig = 1, n
ah (ig+npwx, ibnd) = ah (ig+npwx, ibnd) + spsi (ig+npwx, ibnd)
enddo
enddo
END IF
deallocate (ps)
end subroutine lr_ch_psi_all_k
ENDDO
ENDDO
ENDIF
DEALLOCATE (ps)
END SUBROUTINE lr_ch_psi_all_k
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!gamma part
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_ch_psi_all_gamma()
SUBROUTINE lr_ch_psi_all_gamma()
USE becmod, ONLY : becp, calbec
USE realus, ONLY : real_space, fft_orbital_gamma, &
bfft_orbital_gamma, calbec_rs_gamma, &
s_psir_gamma,real_space_debug
IMPLICIT NONE
real(kind=dp), allocatable :: ps(:,:)
allocate (ps ( nbnd , m))
real(kind=dp), ALLOCATABLE :: ps(:,:)
ALLOCATE (ps ( nbnd , m))
!ikq = ikqs(ik)
ps (:,:) = 0.d0
IF (noncolin) THEN
call errore('lr_ch_psi_all', 'non collin in gamma point not implemented',1)
CALL errore('lr_ch_psi_all', 'non collin in gamma point not implemented',1)
ELSE
CALL DGEMM( 'C', 'N', nbnd, m, n, 2.D0,evc, 2*npwx*npol, spsi, 2*npwx*npol, 0.D0, ps, nbnd )
ENDIF
ps (:,:) = ps(:,:) * alpha_pv
#ifdef __PARA
call mp_sum ( ps, intra_pool_comm )
CALL mp_sum ( ps, intra_pool_comm )
#endif
hpsi (:,:) = (0.d0, 0.d0)
IF (noncolin) THEN
call ZGEMM ('N', 'N', npwx*npol, m, nbnd_occ (ik) , (1.d0, 0.d0) , evc, &
CALL ZGEMM ('N', 'N', npwx*npol, m, nbnd_occ (ik) , (1.d0, 0.d0) , evc, &
npwx*npol, ps, nbnd, (1.d0, 0.d0) , hpsi, npwx*npol)
ELSE
call DGEMM ('N', 'N', 2*n, m, nbnd_occ (ik) , 1.d0 , evc, &
CALL DGEMM ('N', 'N', 2*n, m, nbnd_occ (ik) , 1.d0 , evc, &
2*npwx, ps, nbnd, 1.d0 , hpsi, 2*npwx)
END IF
ENDIF
spsi(:,:) = hpsi(:,:)
!
! And apply S again
!
if (real_space_debug >6 ) then
do ibnd=1,m,2
call fft_orbital_gamma(hpsi,ibnd,m)
call calbec_rs_gamma(ibnd,m,becp%r)
call s_psir_gamma(ibnd,m)
call bfft_orbital_gamma(spsi,ibnd,m)
enddo
else
call calbec (n, vkb, hpsi, becp, m)
call s_psi (npwx, n, m, hpsi, spsi)
endif
do ibnd = 1, m
do ig = 1, n
IF (real_space_debug >6 ) THEN
DO ibnd=1,m,2
CALL fft_orbital_gamma(hpsi,ibnd,m)
CALL calbec_rs_gamma(ibnd,m,becp%r)
CALL s_psir_gamma(ibnd,m)
CALL bfft_orbital_gamma(spsi,ibnd,m)
ENDDO
ELSE
CALL calbec (n, vkb, hpsi, becp, m)
CALL s_psi (npwx, n, m, hpsi, spsi)
ENDIF
DO ibnd = 1, m
DO ig = 1, n
ah (ig, ibnd) = ah (ig, ibnd) + spsi (ig, ibnd)
enddo
enddo
ENDDO
ENDDO
IF (noncolin) THEN
do ibnd = 1, m
do ig = 1, n
DO ibnd = 1, m
DO ig = 1, n
ah (ig+npwx, ibnd) = ah (ig+npwx, ibnd) + spsi (ig+npwx, ibnd)
enddo
enddo
END IF
deallocate (ps)
end subroutine lr_ch_psi_all_gamma
ENDDO
ENDDO
ENDIF
DEALLOCATE (ps)
END SUBROUTINE lr_ch_psi_all_gamma
end subroutine lr_ch_psi_all
END SUBROUTINE lr_ch_psi_all

1126
TDDFPT/src/lr_charg_resp.f90
View File

File diff suppressed because it is too large Load Diff

138
TDDFPT/src/lr_dealloc.f90
View File

@ -1,5 +1,5 @@
!-----------------------------------------------------------------------
subroutine lr_dealloc()
SUBROUTINE lr_dealloc()
!---------------------------------------------------------------------
! ... deallocates all the Lanczos variables
!---------------------------------------------------------------------
@ -7,100 +7,100 @@ subroutine lr_dealloc()
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use lr_variables
use uspp, only : nkb
use control_flags, only : gamma_only
use realus, only : igk_k,npw_k
USE lr_variables
USE uspp, ONLY : nkb
USE control_flags, ONLY : gamma_only
USE realus, ONLY : igk_k,npw_k
USE io_global, ONLY : stdout
use charg_resp, ONLY : w_T_beta_store, w_T_gamma_store, w_T, w_T_zeta_store,chi
use eqv, ONLY : dmuxc
USE charg_resp, ONLY : w_T_beta_store, w_T_gamma_store, w_T, w_T_zeta_store,chi
USE eqv, ONLY : dmuxc
implicit none
IMPLICIT NONE
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_dealloc>")')
endif
ENDIF
!
if (allocated(evc0)) deallocate(evc0)
if (allocated(sevc0)) deallocate(sevc0)
if (allocated(evc1_old)) deallocate(evc1_old)
if (allocated(evc1)) deallocate(evc1)
if (allocated(evc1_new)) deallocate(evc1_new)
if (allocated(sevc1_new)) deallocate(sevc1_new)
if (allocated(d0psi)) deallocate(d0psi)
IF (allocated(evc0)) DEALLOCATE(evc0)
IF (allocated(sevc0)) DEALLOCATE(sevc0)
IF (allocated(evc1_old)) DEALLOCATE(evc1_old)
IF (allocated(evc1)) DEALLOCATE(evc1)
IF (allocated(evc1_new)) DEALLOCATE(evc1_new)
IF (allocated(sevc1_new)) DEALLOCATE(sevc1_new)
IF (allocated(d0psi)) DEALLOCATE(d0psi)
!
if (project) then
deallocate(evc0_virt)
IF (project) THEN
DEALLOCATE(evc0_virt)
!deallocate(sevc0_virt)
deallocate(F)
deallocate(R)
endif
DEALLOCATE(F)
DEALLOCATE(R)
ENDIF
!
if (allocated(rho_1)) deallocate(rho_1)
IF (allocated(rho_1)) DEALLOCATE(rho_1)
!if (allocated(rho_tot)) deallocate(rho_tot)
if (allocated(dmuxc)) deallocate(dmuxc)
if (allocated(igk_k)) deallocate(igk_k)
if (allocated(npw_k)) deallocate(npw_k)
IF (allocated(dmuxc)) DEALLOCATE(dmuxc)
IF (allocated(igk_k)) DEALLOCATE(igk_k)
IF (allocated(npw_k)) DEALLOCATE(npw_k)
!
if (allocated(eval1)) deallocate(eval1)
if (allocated(eval2)) deallocate(eval2)
if (allocated(vl)) deallocate(vl)
if (allocated(vr)) deallocate(vr)
IF (allocated(eval1)) DEALLOCATE(eval1)
IF (allocated(eval2)) DEALLOCATE(eval2)
IF (allocated(vl)) DEALLOCATE(vl)
IF (allocated(vr)) DEALLOCATE(vr)
!
if (allocated(alpha_store)) deallocate(alpha_store)
if (allocated(beta_store)) deallocate(beta_store)
if (allocated(gamma_store)) deallocate(gamma_store)
if (allocated(zeta_store)) deallocate(zeta_store)
IF (allocated(alpha_store)) DEALLOCATE(alpha_store)
IF (allocated(beta_store)) DEALLOCATE(beta_store)
IF (allocated(gamma_store)) DEALLOCATE(gamma_store)
IF (allocated(zeta_store)) DEALLOCATE(zeta_store)
!
!Response charge density related
!
if (allocated(w_T_beta_store)) deallocate(w_T_beta_store)
if (allocated(w_T_gamma_store)) deallocate(w_T_gamma_store)
if (allocated(w_T_zeta_store)) deallocate(w_T_zeta_store)
if (allocated(chi)) deallocate(chi)
if (allocated(w_T)) deallocate(w_T)
if (allocated(rho_1_tot)) deallocate(rho_1_tot)
if (allocated(rho_1_tot_im)) deallocate(rho_1_tot_im)
IF (allocated(w_T_beta_store)) DEALLOCATE(w_T_beta_store)
IF (allocated(w_T_gamma_store)) DEALLOCATE(w_T_gamma_store)
IF (allocated(w_T_zeta_store)) DEALLOCATE(w_T_zeta_store)
IF (allocated(chi)) DEALLOCATE(chi)
IF (allocated(w_T)) DEALLOCATE(w_T)
IF (allocated(rho_1_tot)) DEALLOCATE(rho_1_tot)
IF (allocated(rho_1_tot_im)) DEALLOCATE(rho_1_tot_im)
!
if (gamma_only) then
call lr_dealloc_gamma()
else
call lr_dealloc_k()
endif
IF (gamma_only) THEN
CALL lr_dealloc_gamma()
ELSE
CALL lr_dealloc_k()
ENDIF
!
return
RETURN
!
contains
CONTAINS
!
subroutine lr_dealloc_gamma()
SUBROUTINE lr_dealloc_gamma()
!
use becmod, only : bec_type, becp, deallocate_bec_type
USE becmod, ONLY : bec_type, becp, deallocate_bec_type
!
if (nkb > 0) then
call deallocate_bec_type(becp)
deallocate(becp1)
if (project) then
deallocate(becp1_virt)
endif
endif
IF (nkb > 0) THEN
CALL deallocate_bec_type(becp)
DEALLOCATE(becp1)
IF (project) THEN
DEALLOCATE(becp1_virt)
ENDIF
ENDIF
!
end subroutine lr_dealloc_gamma
END SUBROUTINE lr_dealloc_gamma
!
subroutine lr_dealloc_k()
SUBROUTINE lr_dealloc_k()
!
use becmod, only : bec_type, becp, deallocate_bec_type
USE becmod, ONLY : bec_type, becp, deallocate_bec_type
!
if (nkb > 0) then
call deallocate_bec_type(becp)
deallocate(becp1_c)
if (project) then
deallocate(becp1_c_virt)
endif
endif
IF (nkb > 0) THEN
CALL deallocate_bec_type(becp)
DEALLOCATE(becp1_c)
IF (project) THEN
DEALLOCATE(becp1_c_virt)
ENDIF
ENDIF
!
end subroutine lr_dealloc_k
END SUBROUTINE lr_dealloc_k
!
end subroutine lr_dealloc
END SUBROUTINE lr_dealloc
!-----------------------------------------------------------------------

158
TDDFPT/src/lr_diagonalise.f90
View File

@ -1,5 +1,5 @@
!-----------------------------------------------------------------------
subroutine lr_diagonalise(iter)
SUBROUTINE lr_diagonalise(iter)
!---------------------------------------------------------------------
! Brent Walker, ICTP, 2004
!---------------------------------------------------------------------
@ -9,89 +9,89 @@ subroutine lr_diagonalise(iter)
!
#include "f_defs.h"
!
use io_global, only : stdout
use kinds, only : dp
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE lr_variables, ONLY : lr_verbosity
!
implicit none
IMPLICIT NONE
!
integer,intent(in) :: iter
INTEGER,INTENT(in) :: iter
!
integer :: dimen
real(kind=dp),allocatable :: coeff_mat(:,:)
INTEGER :: dimen
real(kind=dp),ALLOCATABLE :: coeff_mat(:,:)
!
dimen=2*iter
allocate(coeff_mat(dimen,dimen))
ALLOCATE(coeff_mat(dimen,dimen))
coeff_mat(:,:)=0.0d0
call lr_build_matrix_spectrum(coeff_mat,iter)
CALL lr_build_matrix_spectrum(coeff_mat,iter)
!
call lr_diagonalise_matrix(coeff_mat,dimen)
CALL lr_diagonalise_matrix(coeff_mat,dimen)
!
deallocate(coeff_mat)
DEALLOCATE(coeff_mat)
!
return
end subroutine lr_diagonalise
RETURN
END SUBROUTINE lr_diagonalise
!-----------------------------------------------------------------------
subroutine lr_diagonalise_matrix(coeff_mat,dimen)
SUBROUTINE lr_diagonalise_matrix(coeff_mat,dimen)
!
#include "f_defs.h"
!
use io_global, only : stdout
use kinds, only : dp
use lr_variables, only : vl,vr,eval1,eval2
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE lr_variables, ONLY : vl,vr,eval1,eval2
USE io_global, ONLY : stdout
!
implicit none
IMPLICIT NONE
!
! input variables
integer,intent(in) :: dimen
real(kind=dp),intent(in) :: coeff_mat(dimen,dimen)
INTEGER,INTENT(in) :: dimen
real(kind=dp),INTENT(in) :: coeff_mat(dimen,dimen)
!
! local variables
real(kind=dp),allocatable :: work(:)
integer :: info
integer :: i,j
real(kind=dp),ALLOCATABLE :: work(:)
INTEGER :: info
INTEGER :: i,j
real(kind=dp) :: temp1,temp2
real(kind=dp),allocatable :: vl_temp(:),vr_temp(:)
real(kind=dp),ALLOCATABLE :: vl_temp(:),vr_temp(:)
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_diagonalise>")')
endif
if(allocated(eval1)) deallocate(eval1)
if(allocated(eval2)) deallocate(eval2)
if(allocated(vl)) deallocate(vl)
if(allocated(vr)) deallocate(vr)
ENDIF
IF(allocated(eval1)) DEALLOCATE(eval1)
IF(allocated(eval2)) DEALLOCATE(eval2)
IF(allocated(vl)) DEALLOCATE(vl)
IF(allocated(vr)) DEALLOCATE(vr)
!
allocate(eval1(dimen))
allocate(eval2(dimen))
allocate(vl(dimen,dimen))
allocate(vr(dimen,dimen))
ALLOCATE(eval1(dimen))
ALLOCATE(eval2(dimen))
ALLOCATE(vl(dimen,dimen))
ALLOCATE(vr(dimen,dimen))
eval1(:)=0.0d0
eval2(:)=0.0d0
vl(:,:)=0.0d0
vr(:,:)=0.0d0
!
allocate(work(8*dimen))
allocate(vl_temp(dimen),vr_temp(dimen))
ALLOCATE(work(8*dimen))
ALLOCATE(vl_temp(dimen),vr_temp(dimen))
work(:)=0.0d0
vl_temp(:)=0.0d0
vr_temp(:)=0.0d0
!
info=0
!
call dgeev('v','v',dimen,coeff_mat,dimen,eval1,eval2, &
CALL dgeev('v','v',dimen,coeff_mat,dimen,eval1,eval2, &
vl,dimen,vr,dimen,work,8*dimen,info)
!
if (info/=0) then
call errore(' lr_main ', 'Diagonalisation of coefficient ' // &
IF (info/=0) THEN
CALL errore(' lr_main ', 'Diagonalisation of coefficient ' // &
& 'matrix unsuccessful',1)
endif
ENDIF
!
if(.true.) then
IF(.true.) THEN
! sort the eigenvalues (inefficient)
do i=1,dimen
do j=1,i
if(eval1(i)<eval1(j)) then
DO i=1,dimen
DO j=1,i
IF(eval1(i)<eval1(j)) THEN
temp1=eval1(i)
temp2=eval2(i)
vl_temp(:)=vl(:,i)
@ -104,52 +104,52 @@ subroutine lr_diagonalise_matrix(coeff_mat,dimen)
eval2(j)=temp2
vl(:,j)=vl_temp(:)
vr(:,j)=vr_temp(:)
endif
enddo
enddo
endif
ENDIF
ENDDO
ENDDO
ENDIF
!
write(stdout,'(5X,"# < start of eigenvalue listing >")')
do i=1,dimen
write(stdout,'(5X,i5,2(1X,f20.12))') i,eval1(i),eval2(i)
enddo
write(stdout,'(5X,"# < end of eigenvalue listing >")')
WRITE(stdout,'(5X,"# < start of eigenvalue listing >")')
DO i=1,dimen
WRITE(stdout,'(5X,i5,2(1X,f20.12))') i,eval1(i),eval2(i)
ENDDO
WRITE(stdout,'(5X,"# < end of eigenvalue listing >")')
!
deallocate(work)
deallocate(vl_temp)
deallocate(vr_temp)
DEALLOCATE(work)
DEALLOCATE(vl_temp)
DEALLOCATE(vr_temp)
!
return
RETURN
!
end subroutine lr_diagonalise_matrix
END SUBROUTINE lr_diagonalise_matrix
!-----------------------------------------------------------------------
subroutine lr_build_matrix_spectrum(coeff_mat,iter)
SUBROUTINE lr_build_matrix_spectrum(coeff_mat,iter)
!---------------------------------------------------------------------
! ... version for non-hermitian lanczos scheme
!---------------------------------------------------------------------
!
#include "f_defs.h"
!
use io_global, only : stdout
use kinds, only : dp
use lr_variables, only : a,b
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE lr_variables, ONLY : a,b
!
implicit none
IMPLICIT NONE
!
integer,intent(in) :: iter
INTEGER,INTENT(in) :: iter
real(kind=dp) :: coeff_mat(2*iter,2*iter)
!
integer :: i,j
INTEGER :: i,j
!
do i=1,iter
DO i=1,iter
coeff_mat(i,i)=1.0d0
enddo
ENDDO
coeff_mat(1,1)=0.0d0
coeff_mat(2,2)=0.0d0
coeff_mat(1,2)=a(1,1)
coeff_mat(2,1)=a(2,1)
!
trirecursion: do i = 2, iter
trirecursion: DO i = 2, iter
coeff_mat(2*i-1,2*i-1)=0.0d0
coeff_mat(2*i+0,2*i+0)=0.0d0
coeff_mat(2*i-1,2*i+0)=a(1,i)
@ -161,17 +161,17 @@ subroutine lr_build_matrix_spectrum(coeff_mat,iter)
coeff_mat(2*i-2,2*i+0)=b(2,i)
coeff_mat(2*i-1,2*i-3)=abs(b(2,i))
coeff_mat(2*i+0,2*i-2)=abs(b(1,i))
end do trirecursion
ENDDO trirecursion
!
if(.false.) then
do i=1,2*iter
do j=1,2*iter
write(stdout,'(f10.5,$)') coeff_mat(i,j)
enddo
write(stdout,*)
enddo
endif
IF(.false.) THEN
DO i=1,2*iter
DO j=1,2*iter
WRITE(stdout,'(f10.5,$)') coeff_mat(i,j)
ENDDO
WRITE(stdout,*)
ENDDO
ENDIF
!
return
end subroutine lr_build_matrix_spectrum
RETURN
END SUBROUTINE lr_build_matrix_spectrum
!-----------------------------------------------------------------------

100
TDDFPT/src/lr_dot.f90
View File

@ -1,10 +1,10 @@
!-----------------------------------------------------------------------
!
function lr_dot(x,y)
FUNCTION lr_dot(x,y)
!---------------------------------------------------------------------
! Brent Walker, ICTP, 2004
!---------------------------------------------------------------------
! ... wrapper for PWSCF linear response inner product routines
! ... wrapper for PWSCF linear response inner product routines
! ... sums over the bands
! ... call for each k-point with arguments:
! ... call lr_dot(npw_k(ik),evc1(1,1,ik,1),1,evc1(1,1,ik,2),1)
@ -12,97 +12,97 @@ function lr_dot(x,y)
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use io_global, only : stdout
use kinds, only : dp
use klist, only : nks
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE klist, ONLY : nks
!use lr_variables, only : npw_k
use realus, only : npw_k
use lsda_mod, only : nspin
use wvfct, only : npwx,nbnd,wg
use control_flags, only : gamma_only
use gvect, only : gstart
use mp, only : mp_sum
USE realus, ONLY : npw_k
USE lsda_mod, ONLY : nspin
USE wvfct, ONLY : npwx,nbnd,wg
USE control_flags, ONLY : gamma_only
USE gvect, ONLY : gstart
USE mp, ONLY : mp_sum
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
USE lr_variables, ONLY : lr_verbosity
USE io_global, ONLY : stdout
!
implicit none
IMPLICIT NONE
!
complex(kind=dp) :: x(npwx,nbnd,nks),y(npwx,nbnd,nks)
complex(kind=dp) :: lr_dot
complex(kind=dp) :: temp_k
COMPLEX(kind=dp) :: x(npwx,nbnd,nks),y(npwx,nbnd,nks)
COMPLEX(kind=dp) :: lr_dot
COMPLEX(kind=dp) :: temp_k
real(kind=dp) :: temp_gamma
real(kind=dp) :: degspin
integer :: ibnd
integer :: ik
real(kind=dp), external :: DDOT
complex(kind=dp), external :: ZDOTC
INTEGER :: ibnd
INTEGER :: ik
real(kind=dp), EXTERNAL :: DDOT
COMPLEX(kind=dp), EXTERNAL :: ZDOTC
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_dot>")')
endif
call start_clock ('lr_dot')
!
ENDIF
CALL start_clock ('lr_dot')
!
lr_dot=(0.0d0,0.0d0)
!
temp_gamma=0.0d0
temp_k=(0.0d0,0.0d0)
!
degspin=2.0d0
if(nspin==2) degspin=1.0d0
IF(nspin==2) degspin=1.0d0
!
if(gamma_only) then
call lr_dot_gamma()
IF(gamma_only) THEN
CALL lr_dot_gamma()
lr_dot=cmplx(temp_gamma,0.0d0,dp)
else
call lr_dot_k()
ELSE
CALL lr_dot_k()
lr_dot=temp_k
endif
ENDIF
!
lr_dot=lr_dot/degspin
!
if (lr_verbosity > 5) WRITE(stdout,'("<end of lr_dot>")')
call stop_clock ('lr_dot')
IF (lr_verbosity > 5) WRITE(stdout,'("<end of lr_dot>")')
CALL stop_clock ('lr_dot')
!
return
RETURN
!
contains
CONTAINS
!
subroutine lr_dot_gamma
SUBROUTINE lr_dot_gamma
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
temp_gamma = temp_gamma + 2.D0*wg(ibnd,1)*DDOT(2*npw_k(1),x(:,ibnd,1),1,y(:,ibnd,1),1)
if (gstart==2) temp_gamma = temp_gamma - wg(ibnd,1)*dble(x(1,ibnd,1))*dble(y(1,ibnd,1))
IF (gstart==2) temp_gamma = temp_gamma - wg(ibnd,1)*dble(x(1,ibnd,1))*dble(y(1,ibnd,1))
!
enddo
ENDDO
!
#ifdef __PARA
!call reduce(1,temp_gamma)
call mp_sum(temp_gamma, intra_pool_comm)
CALL mp_sum(temp_gamma, intra_pool_comm)
#endif
!
return
end subroutine lr_dot_gamma
RETURN
END SUBROUTINE lr_dot_gamma
!
subroutine lr_dot_k
SUBROUTINE lr_dot_k
!
do ik=1,nks
do ibnd=1,nbnd
DO ik=1,nks
DO ibnd=1,nbnd
!
temp_k=temp_k+wg(ibnd,ik)*ZDOTC(npw_k(ik),x(1,ibnd,ik),1,y(1,ibnd,ik),1)
!
enddo
enddo
ENDDO
ENDDO
#ifdef __PARA
!call poolreduce(2,temp_k)
call mp_sum(temp_k,inter_pool_comm)
CALL mp_sum(temp_k,inter_pool_comm)
!call reduce(2,temp_k)
call mp_sum(temp_k, intra_pool_comm)
CALL mp_sum(temp_k, intra_pool_comm)
#endif
!
return
end subroutine lr_dot_k
RETURN
END SUBROUTINE lr_dot_k
!
end function lr_dot
END FUNCTION lr_dot
!-----------------------------------------------------------------------

50
TDDFPT/src/lr_dv_setup.f90
View File

@ -8,11 +8,11 @@
! Adapted to TDDFPT by Osman Baris Malcioglu (2009)
!-----------------------------------------------------------------------
subroutine lr_dv_setup
SUBROUTINE lr_dv_setup
!-----------------------------------------------------------------------
!
! This subroutine prepares some variable which is needed for derivatives
! 1) Set non linear core correction stuff
! 1) Set non linear core correction stuff
! 2) computes dmuxc 3) with GC if needed
!
#include "f_defs.h"
@ -28,27 +28,27 @@ subroutine lr_dv_setup
!USE lr_variables, ONLY : dmuxc, nlcc_any
USE nlcc_ph, ONLY : nlcc_any
USE eqv, ONLY : dmuxc
USE funct, ONLY : dmxc, dmxc_spin
USE funct, ONLY : dmxc, dmxc_spin
USE lr_variables, ONLY : lr_verbosity
USE io_global, ONLY : stdout
implicit none
IMPLICIT NONE
!
real(DP) :: rhotot, rhoup, rhodw
! total charge
! total up charge
! total down charge
!
integer :: nt, ir
INTEGER :: nt, ir
! counter on mesh points
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_dv_setup>")')
endif
call start_clock ('lr_dv_setup')
ENDIF
CALL start_clock ('lr_dv_setup')
!
! 1) Set non linear core correction stuff
!
nlcc_any = ANY ( upf(1:ntyp)%nlcc )
nlcc_any = any ( upf(1:ntyp)%nlcc )
!do nt = 1, ntyp
! nlcc_any = nlcc_any.or.nlcc (nt)
!enddo
@ -56,28 +56,28 @@ subroutine lr_dv_setup
! 2) Computes the derivative of the xc potential
!
dmuxc(:,:,:) = 0.0D0
if (lsda) then
do ir = 1, nrxx
IF (lsda) THEN
DO ir = 1, nrxx
rhoup = rho%of_r (ir, 1) + 0.5d0 * rho_core (ir)
rhodw = rho%of_r (ir, 2) + 0.5d0 * rho_core (ir)
call dmxc_spin (rhoup, rhodw, dmuxc(ir,1,1), dmuxc(ir,2,1), &
CALL dmxc_spin (rhoup, rhodw, dmuxc(ir,1,1), dmuxc(ir,2,1), &
dmuxc(ir,1,2), dmuxc(ir,2,2) )
enddo
else
do ir = 1, nrxx
ENDDO
ELSE
DO ir = 1, nrxx
rhotot = rho%of_r (ir, 1) + rho_core (ir)
if (rhotot.gt.1.d-30) dmuxc (ir, 1, 1) = dmxc (rhotot)
if (rhotot.lt.-1.d-30) dmuxc (ir, 1, 1) = -dmxc ( -rhotot)
enddo
endif
deallocate(rho_core)
IF (rhotot>1.d-30) dmuxc (ir, 1, 1) = dmxc (rhotot)
IF (rhotot<-1.d-30) dmuxc (ir, 1, 1) = -dmxc ( -rhotot)
ENDDO
ENDIF
DEALLOCATE(rho_core)
!
! 3) Setup all gradient correction stuff
!
call lr_setup_dgc()
CALL lr_setup_dgc()
!
if (lr_verbosity > 5) WRITE(stdout,'("<end of lr_dv_setup>")')
call stop_clock ('lr_dv_setup')
IF (lr_verbosity > 5) WRITE(stdout,'("<end of lr_dv_setup>")')
CALL stop_clock ('lr_dv_setup')
!
return
end subroutine lr_dv_setup
RETURN
END SUBROUTINE lr_dv_setup

790
TDDFPT/src/lr_dvpsi_e.f90
View File

File diff suppressed because it is too large Load Diff

176
TDDFPT/src/lr_h_psiq.f90
View File

@ -7,7 +7,7 @@
!
!
!-----------------------------------------------------------------------
subroutine lr_h_psiq (lda, n, m, psi, hpsi, spsi)
SUBROUTINE lr_h_psiq (lda, n, m, psi, hpsi, spsi)
!-----------------------------------------------------------------------
!
!
@ -24,33 +24,33 @@ subroutine lr_h_psiq (lda, n, m, psi, hpsi, spsi)
USE wavefunctions_module, ONLY : psic, psic_nc
USE noncollin_module, ONLY : noncolin, npol
USE lsda_mod, ONLY : current_spin
use fft_base, only : dffts
use fft_interfaces, only : fwfft, invfft
USE fft_base, ONLY : dffts
USE fft_interfaces, ONLY : fwfft, invfft
USE gvecs, ONLY : nls
USE spin_orb, ONLY : domag
USE scf, ONLY : vrs
USE uspp, ONLY : vkb
USE wvfct, ONLY : g2kin,igk
USE lr_variables, ONLY : lr_verbosity
use control_flags, only : gamma_only
use io_global, only : stdout
USE control_flags, ONLY : gamma_only
USE io_global, ONLY : stdout
!USE qpoint, ONLY : igkq
implicit none
IMPLICIT NONE
!
! Here the local variables
!
integer :: ibnd
INTEGER :: ibnd
! counter on bands
integer :: lda, n, m
INTEGER :: lda, n, m
! input: the leading dimension of the array psi
! input: the real dimension of psi
! input: the number of psi to compute
integer :: j
INTEGER :: j
! do loop index
complex(DP) :: psi (lda*npol, m), hpsi (lda*npol, m), spsi (lda*npol, m)
complex(DP) :: sup, sdwn
COMPLEX(DP) :: psi (lda*npol, m), hpsi (lda*npol, m), spsi (lda*npol, m)
COMPLEX(DP) :: sup, sdwn
! input: the functions where to apply H and S
! output: H times psi
! output: S times psi (Us PP's only)
@ -59,36 +59,36 @@ subroutine lr_h_psiq (lda, n, m, psi, hpsi, spsi)
!complex(kind=dp), external :: ZDOTC
call start_clock ('h_psiq')
If (lr_verbosity > 5) WRITE(stdout,'("<lr_h_psiq>")')
if (gamma_only) then
call lr_h_psiq_gamma()
else
call lr_h_psiq_k()
endif
call stop_clock ('h_psiq')
return
contains
CALL start_clock ('h_psiq')
IF (lr_verbosity > 5) WRITE(stdout,'("<lr_h_psiq>")')
IF (gamma_only) THEN
CALL lr_h_psiq_gamma()
ELSE
CALL lr_h_psiq_k()
ENDIF
CALL stop_clock ('h_psiq')
RETURN
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!k point part
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_h_psiq_k()
SUBROUTINE lr_h_psiq_k()
USE becmod, ONLY : bec_type, becp, calbec
IMPLICIT NONE
call start_clock ('init')
CALL start_clock ('init')
call calbec ( n, vkb, psi, becp, m)
CALL calbec ( n, vkb, psi, becp, m)
!
! Here we apply the kinetic energy (k+G)^2 psi
!
hpsi=(0.d0,0.d0)
do ibnd = 1, m
do j = 1, n
DO ibnd = 1, m
DO j = 1, n
hpsi (j, ibnd) = g2kin (j) * psi (j, ibnd)
enddo
enddo
ENDDO
ENDDO
IF (noncolin) THEN
DO ibnd = 1, m
DO j = 1, n
@ -96,106 +96,106 @@ contains
ENDDO
ENDDO
ENDIF
call stop_clock ('init')
CALL stop_clock ('init')
!
! the local potential V_Loc psi. First the psi in real space
!
do ibnd = 1, m
call start_clock ('firstfft')
DO ibnd = 1, m
CALL start_clock ('firstfft')
IF (noncolin) THEN
psic_nc = (0.d0, 0.d0)
do j = 1, n
DO j = 1, n
psic_nc(nls(igk(j)),1) = psi (j, ibnd)
psic_nc(nls(igk(j)),2) = psi (j+lda, ibnd)
enddo
ENDDO
CALL invfft ('Wave', psic_nc(:,1), dffts)
CALL invfft ('Wave', psic_nc(:,2), dffts)
ELSE
psic(:) = (0.d0, 0.d0)
do j = 1, n
DO j = 1, n
psic (nls(igk(j))) = psi (j, ibnd)
enddo
ENDDO
CALL invfft ('Wave', psic, dffts)
END IF
call stop_clock ('firstfft')
ENDIF
CALL stop_clock ('firstfft')
!
! and then the product with the potential vrs = (vltot+vr) on the smoo
!
if (noncolin) then
if (domag) then
do j=1, dffts%nnr
IF (noncolin) THEN
IF (domag) THEN
DO j=1, dffts%nnr
sup = psic_nc(j,1) * (vrs(j,1)+vrs(j,4)) + &
psic_nc(j,2) * (vrs(j,2)-(0.d0,1.d0)*vrs(j,3))
sdwn = psic_nc(j,2) * (vrs(j,1)-vrs(j,4)) + &
psic_nc(j,1) * (vrs(j,2)+(0.d0,1.d0)*vrs(j,3))
psic_nc(j,1)=sup
psic_nc(j,2)=sdwn
end do
else
do j=1, dffts%nnr
ENDDO
ELSE
DO j=1, dffts%nnr
psic_nc(j,1)=psic_nc(j,1) * vrs(j,1)
psic_nc(j,2)=psic_nc(j,2) * vrs(j,1)
enddo
endif
else
do j = 1, dffts%nnr
ENDDO
ENDIF
ELSE
DO j = 1, dffts%nnr
psic (j) = psic (j) * vrs (j, current_spin)
enddo
endif
ENDDO
ENDIF
!
! back to reciprocal space
!
call start_clock ('secondfft')
CALL start_clock ('secondfft')
IF (noncolin) THEN
CALL fwfft ('Wave', psic_nc(:,1), dffts)
CALL fwfft ('Wave', psic_nc(:,2), dffts)
!
! addition to the total product
!
do j = 1, n
DO j = 1, n
hpsi (j, ibnd) = hpsi (j, ibnd) + psic_nc (nls(igk(j)), 1)
hpsi (j+lda, ibnd) = hpsi (j+lda, ibnd) + psic_nc (nls(igk(j)), 2)
enddo
ENDDO
ELSE
CALL fwfft ('Wave', psic, dffts)
!
! addition to the total product
!
do j = 1, n
DO j = 1, n
hpsi (j, ibnd) = hpsi (j, ibnd) + psic (nls(igk(j)))
enddo
END IF
call stop_clock ('secondfft')
enddo
ENDDO
ENDIF
CALL stop_clock ('secondfft')
ENDDO
!
! Here the product with the non local potential V_NL psi
!
call add_vuspsi (lda, n, m, hpsi)
CALL add_vuspsi (lda, n, m, hpsi)
call s_psi (lda, n, m, psi, spsi)
CALL s_psi (lda, n, m, psi, spsi)
end subroutine lr_h_psiq_k
END SUBROUTINE lr_h_psiq_k
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!gamma point part
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_h_psiq_gamma()
SUBROUTINE lr_h_psiq_gamma()
USE becmod, ONLY : becp, calbec
USE gvect, ONLY : gstart
USE realus, ONLY : real_space, fft_orbital_gamma, &
bfft_orbital_gamma, calbec_rs_gamma, add_vuspsir_gamma, &
v_loc_psir, s_psir_gamma, real_space_debug
use uspp, only : nkb
USE uspp, ONLY : nkb
IMPLICIT NONE
call start_clock ('init')
CALL start_clock ('init')
!
! Here we apply the kinetic energy (k+G)^2 psi
!
if(gstart==2) psi(1,:)=cmplx(real(psi(1,:),dp),0.0d0,dp)
IF(gstart==2) psi(1,:)=cmplx(real(psi(1,:),dp),0.0d0,dp)
!
!!OBM debug
! obm_debug=0
@ -207,11 +207,11 @@ contains
! print *, "lr_h_psiq psi", obm_debug
!!obm_debug
do ibnd=1,m
do j=1,n
DO ibnd=1,m
DO j=1,n
hpsi(j,ibnd)=g2kin(j)*psi(j,ibnd)
enddo
enddo
ENDDO
ENDDO
!!OBM debug
! obm_debug=0
! do ibnd=1,m
@ -222,21 +222,21 @@ contains
! print *, "lr_h_psiq hpsi (just after kinetic operator)", obm_debug
!!obm_debug
call stop_clock ('init')
if (nkb > 0 .and. real_space_debug>2) then
do ibnd=1,m,2
CALL stop_clock ('init')
IF (nkb > 0 .and. real_space_debug>2) THEN
DO ibnd=1,m,2
!call check_fft_orbital_gamma(psi,ibnd,m)
call fft_orbital_gamma(psi,ibnd,m,.true.) !transform the psi real space, saved in temporary memory
call calbec_rs_gamma(ibnd,m,becp%r) !rbecp on psi
call s_psir_gamma(ibnd,m) !psi -> spsi
call bfft_orbital_gamma(spsi,ibnd,m) !return back to real space
call fft_orbital_gamma(hpsi,ibnd,m) ! spsi above is now replaced by hpsi
call v_loc_psir(ibnd,m) ! hpsi -> hpsi + psi*vrs (psi read from temporary memory)
call add_vuspsir_gamma(ibnd,m) ! hpsi -> hpsi + vusp
call bfft_orbital_gamma(hpsi,ibnd,m,.true.) !transform back hpsi, clear psi in temporary memory
enddo
CALL fft_orbital_gamma(psi,ibnd,m,.true.) !transform the psi real space, saved in temporary memory
CALL calbec_rs_gamma(ibnd,m,becp%r) !rbecp on psi
CALL s_psir_gamma(ibnd,m) !psi -> spsi
CALL bfft_orbital_gamma(spsi,ibnd,m) !return back to real space
CALL fft_orbital_gamma(hpsi,ibnd,m) ! spsi above is now replaced by hpsi
CALL v_loc_psir(ibnd,m) ! hpsi -> hpsi + psi*vrs (psi read from temporary memory)
CALL add_vuspsir_gamma(ibnd,m) ! hpsi -> hpsi + vusp
CALL bfft_orbital_gamma(hpsi,ibnd,m,.true.) !transform back hpsi, clear psi in temporary memory
ENDDO
ELSE
call vloc_psi_gamma(lda,n,m,psi,vrs(1,current_spin),hpsi)
CALL vloc_psi_gamma(lda,n,m,psi,vrs(1,current_spin),hpsi)
!!OBM debug
! obm_debug=0
! do ibnd=1,m
@ -248,10 +248,10 @@ contains
!!obm_debug
IF (noncolin) THEN
call errore ("lr_h_psiq","gamma and noncolin not implemented yet",1)
CALL errore ("lr_h_psiq","gamma and noncolin not implemented yet",1)
ELSE
call calbec ( n, vkb, psi, becp, m)
END IF
CALL calbec ( n, vkb, psi, becp, m)
ENDIF
!!OBM debug
! obm_debug=0
! do ibnd=1,m
@ -263,7 +263,7 @@ contains
!!obm_debug
call add_vuspsi (lda, n, m, hpsi)
CALL add_vuspsi (lda, n, m, hpsi)
!END IF
!!OBM debug
! obm_debug=0
@ -275,7 +275,7 @@ contains
! print *, "lr_h_psiq hpsi (after add_vuspsi)", obm_debug
!!obm_debug
call s_psi (lda, n, m, psi, spsi)
CALL s_psi (lda, n, m, psi, spsi)
!!OBM debug
! obm_debug=0
! do ibnd=1,m
@ -286,6 +286,6 @@ contains
! print *, "lr_h_psiq spsi ", obm_debug
!!obm_debug
ENDIF
end subroutine lr_h_psiq_gamma
END SUBROUTINE lr_h_psiq_gamma
end subroutine lr_h_psiq
END SUBROUTINE lr_h_psiq

100
TDDFPT/src/lr_init_nfo.f90
View File

@ -1,17 +1,17 @@
!--------------------------------------------------------------
!OBM This subroutine initialises stuff related to open shell
!OBM This subroutine initialises stuff related to open shell
! calculations (kpoint > 1 degauss/=0 or nspin/=1)
!-------------------------------------------------------------
#include "f_defs.h"
subroutine lr_init_nfo()
SUBROUTINE lr_init_nfo()
!
!Created by Osman Baris Malcioglu (2009)
!
!
USE kinds, ONLY : DP
use klist, only : nks,degauss,lgauss,ngauss,xk, nelec
USE wvfct, ONLY : nbnd, et, igk, npw, g2kin
use realus, only : npw_k, igk_k
USE klist, ONLY : nks,degauss,lgauss,ngauss,xk, nelec
USE wvfct, ONLY : nbnd, et, igk, npw, g2kin
USE realus, ONLY : npw_k, igk_k
USE lr_variables, ONLY : lr_verbosity
USE io_global, ONLY : stdout
USE constants, ONLY : pi, degspin
@ -25,22 +25,22 @@ subroutine lr_init_nfo()
USE lsda_mod, ONLY : lsda
USE realus, ONLY : real_space
USE control_ph, ONLY : alpha_pv, nbnd_occ
use wvfct, only : npwx, ecutwfc
use klist, only : nks
USE wvfct, ONLY : npwx, ecutwfc
USE klist, ONLY : nks
!
implicit none
IMPLICIT NONE
!
! local variables
real(kind=DP) :: small, emin, emax, xmax, fac, targ
integer :: ik,ibnd, ipol
INTEGER :: ik,ibnd, ipol
!
! Open shell related
IF ( .not. ALLOCATED( igk_k ) ) allocate(igk_k(npwx,nks))
IF ( .not. ALLOCATED( npw_k ) ) allocate(npw_k(nks))
IF ( .not. allocated( igk_k ) ) ALLOCATE(igk_k(npwx,nks))
IF ( .not. allocated( npw_k ) ) ALLOCATE(npw_k(nks))
!IF ( .not. ALLOCATED( nbnd_occ ) ) allocate (nbnd_occ (nks))
if (.not. real_space) then
do ik=1,nks
IF (.not. real_space) THEN
DO ik=1,nks
!
CALL gk_sort( xk(1,ik), ngm, g, ( ecutwfc / tpiba2 ), npw, igk, g2kin )
!
@ -49,14 +49,14 @@ subroutine lr_init_nfo()
igk_k(:,ik) = igk(:)
!
!
enddo
endif
ENDDO
ENDIF
!OBM!! The following part is derived from phonon phq_setup
!
! 5) Computes the number of occupied bands for each k point
!
!if (.not. allocated (nbnd_occ) allocate( nbnd_occ (nks) )
if (lgauss) then
IF (lgauss) THEN
!
! discard conduction bands such that w0gauss(x,n) < small
!
@ -73,61 +73,61 @@ subroutine lr_init_nfo()
!
! - appropriate limit for Fermi-Dirac
!
if (ngauss.eq. - 99) then
IF (ngauss== - 99) THEN
fac = 1.d0 / sqrt (small)
xmax = 2.d0 * log (0.5d0 * (fac + sqrt (fac * fac - 4.d0) ) )
endif
ENDIF
targ = ef + xmax * degauss
do ik = 1, nks
do ibnd = 1, nbnd
if (et (ibnd, ik) .lt.targ) nbnd_occ (ik) = ibnd
enddo
if (nbnd_occ (ik) .eq.nbnd) WRITE( stdout, '(5x,/,&
DO ik = 1, nks
DO ibnd = 1, nbnd
IF (et (ibnd, ik) <targ) nbnd_occ (ik) = ibnd
ENDDO
IF (nbnd_occ (ik) ==nbnd) WRITE( stdout, '(5x,/,&
&"Possibly too few bands at point ", i4,3f10.5)') &
ik, (xk (ipol, ik) , ipol = 1, 3)
enddo
else if (ltetra) then
call errore('lr_init_nfo','phonon + tetrahedra not implemented', 1)
else
if (lsda) call infomsg('lr_init_nfo','occupation numbers probably wrong')
if (noncolin) then
nbnd_occ = nint (nelec)
else
do ik = 1, nks
ENDDO
ELSEIF (ltetra) THEN
CALL errore('lr_init_nfo','phonon + tetrahedra not implemented', 1)
ELSE
IF (lsda) CALL infomsg('lr_init_nfo','occupation numbers probably wrong')
IF (noncolin) THEN
nbnd_occ = nint (nelec)
ELSE
DO ik = 1, nks
nbnd_occ (ik) = nint (nelec) / degspin
enddo
endif
endif
ENDDO
ENDIF
ENDIF
!
! 6) Computes alpha_pv
!
emin = et (1, 1)
do ik = 1, nks
do ibnd = 1, nbnd
DO ik = 1, nks
DO ibnd = 1, nbnd
emin = min (emin, et (ibnd, ik) )
enddo
enddo
ENDDO
ENDDO
#ifdef __PARA
! find the minimum across pools
call mp_min( emin, inter_pool_comm )
CALL mp_min( emin, inter_pool_comm )
#endif
if (lgauss) then
IF (lgauss) THEN
emax = targ
alpha_pv = emax - emin
else
ELSE
emax = et (1, 1)
do ik = 1, nks
do ibnd = 1, nbnd_occ(ik)
DO ik = 1, nks
DO ibnd = 1, nbnd_occ(ik)
emax = max (emax, et (ibnd, ik) )
enddo
enddo
ENDDO
ENDDO
#ifdef __PARA
! find the maximum across pools
call mp_max( emax, inter_pool_comm )
CALL mp_max( emax, inter_pool_comm )
#endif
alpha_pv = 2.d0 * (emax - emin)
endif
ENDIF
! avoid zero value for alpha_pv
alpha_pv = max (alpha_pv, 1.0d-2)
return
end subroutine lr_init_nfo
RETURN
END SUBROUTINE lr_init_nfo

352
TDDFPT/src/lr_lanczos.f90
View File

@ -1,9 +1,9 @@
module lr_lanczos
contains
MODULE lr_lanczos
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! OBM :
!
! This subroutine handles two interleaved non-hermitian chains for x and y at the same time,
! This subroutine handles two interleaved non-hermitian chains for x and y at the same time,
!
! in the beginning
! for odd steps evc1(:,:,:,1) corresponds to q of y and evc1(:,:,:,2) corresponds to p of x
@ -13,116 +13,116 @@ contains
! altering the A matrix correspondingly for even and odd steps correspondingly.
! This change is controlled by the interaction parameter in lr_apply_liouvillian
!
! For further reference please refer to eq. (32) and (33) in
! For further reference please refer to eq. (32) and (33) in
! Ralph Gebauer, Brent Walker J. Chem. Phys., 127, 164106 (2007)
!
! Modified by Osman Baris Malcioglu (2009)
subroutine one_lanczos_step()
SUBROUTINE one_lanczos_step()
!
! Non-Hermitian Lanczos
!
USE io_global, ONLY : ionode, stdout
use kinds, only : dp
use klist, only : nks,xk
use lr_variables, only : n_ipol, ltammd, itermax,&
USE kinds, ONLY : dp
USE klist, ONLY : nks,xk
USE lr_variables, ONLY : n_ipol, ltammd, itermax,&
evc1, evc1_new, sevc1_new, evc1_old, &
evc0, sevc0, d0psi, &
alpha_store, beta_store, gamma_store, zeta_store,&
charge_response, size_evc, LR_polarization, LR_iteration,&!,real_space
test_case_no
use uspp, only : vkb, nkb, okvan
use wvfct, only : nbnd, npwx, npw
use control_flags, only : gamma_only,tqr
use becmod, only : bec_type, becp, calbec
USE uspp, ONLY : vkb, nkb, okvan
USE wvfct, ONLY : nbnd, npwx, npw
USE control_flags, ONLY : gamma_only,tqr
USE becmod, ONLY : bec_type, becp, calbec
!use real_beta, only : ccalbecr_gamma,s_psir,fft_orbital_gamma,bfft_orbital_gamma
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
bfft_orbital_gamma, calbec_rs_gamma, add_vuspsir_gamma, &
v_loc_psir, s_psir_gamma, igk_k,npw_k, real_space_debug
USE lr_variables, ONLY : lr_verbosity
use charg_resp, only : w_T_beta_store,w_T,lr_calc_F
USE charg_resp, ONLY : w_T_beta_store,w_T,lr_calc_F
!Debugging
USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,check_vector_gamma
!
implicit none
IMPLICIT NONE
!
complex(kind=dp),external :: lr_dot
COMPLEX(kind=dp),EXTERNAL :: lr_dot
!
!integer,intent(in) :: iter, pol
integer :: ik, ip, ibnd,ig, pol_index
INTEGER :: ik, ip, ibnd,ig, pol_index
!
character(len=6), external :: int_to_char
CHARACTER(len=6), EXTERNAL :: int_to_char
!
! Local variables
!
real(kind=dp) :: alpha, beta, gamma, temp
!
complex(kind=dp) :: zeta
COMPLEX(kind=dp) :: zeta
!
!integer :: n
!
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_lanczos_one_step>")')
endif
If (lr_verbosity > 10) THEN
print *, "Real space = ", real_space
print *, "Real space debug ", real_space_debug
print *, "TQR = ", tqr
endif
ENDIF
IF (lr_verbosity > 10) THEN
PRINT *, "Real space = ", real_space
PRINT *, "Real space debug ", real_space_debug
PRINT *, "TQR = ", tqr
ENDIF
!
call start_clock('one_step')
CALL start_clock('one_step')
pol_index=1
if ( n_ipol /= 1 ) pol_index=LR_polarization
IF ( n_ipol /= 1 ) pol_index=LR_polarization
!
! Calculation of zeta coefficients
!
if (mod(LR_iteration,2)==0) then
IF (mod(LR_iteration,2)==0) THEN
!
do ip=1,n_ipol
DO ip=1,n_ipol
!
zeta = lr_dot(d0psi(:,:,:,ip),evc1(:,:,:,1)) !Why gamma point dot?
zeta_store (pol_index,ip,LR_iteration) = zeta
write(stdout,'(5x,"z1= ",1x,i6,2(1x,e21.15))') ip,real(zeta),aimag(zeta)
WRITE(stdout,'(5x,"z1= ",1x,i6,2(1x,e21.15))') ip,real(zeta),aimag(zeta)
!
end do
ENDDO
!evc1(:,:,:,1) contains the q of x for even steps, lets calculate the response related observables
!
if (charge_response == 1) then
call lr_calc_dens(evc1(:,:,:,1), .true.)
call lr_calc_F(evc1(:,:,:,1))
endif
IF (charge_response == 1) THEN
CALL lr_calc_dens(evc1(:,:,:,1), .true.)
CALL lr_calc_F(evc1(:,:,:,1))
ENDIF
!
!
else
ELSE
!
do ip=1,n_ipol
DO ip=1,n_ipol
!
zeta = (0.0d0,0.0d0)
zeta_store (pol_index,ip,LR_iteration) = zeta
write(stdout,'(5x,"z1= ",1x,i6,2(1x,e21.15))') ip,real(zeta),aimag(zeta)
WRITE(stdout,'(5x,"z1= ",1x,i6,2(1x,e21.15))') ip,real(zeta),aimag(zeta)
!
end do
ENDDO
!
endif
!
ENDIF
!
! Application of the Liouvillian superoperator for the first iteration
!
if(LR_iteration==1) then
IF(LR_iteration==1) THEN
LR_iteration=0 !Charge response dump related part is disabled by setting this to zero
if(.not.ltammd) then
call lr_apply_liouvillian(evc1(:,:,:,1),evc1_new(:,:,:,1),sevc1_new(:,:,:,1),.false.)
call lr_apply_liouvillian(evc1(:,:,:,2),evc1_new(:,:,:,2),sevc1_new(:,:,:,2),.true.)
else
call lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.true.)
IF(.not.ltammd) THEN
CALL lr_apply_liouvillian(evc1(:,:,:,1),evc1_new(:,:,:,1),sevc1_new(:,:,:,1),.false.)
CALL lr_apply_liouvillian(evc1(:,:,:,2),evc1_new(:,:,:,2),sevc1_new(:,:,:,2),.true.)
ELSE
CALL lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.true.)
evc1(:,:,:,2)=evc1(:,:,:,1)
evc1_new(:,:,:,2)=evc1_new(:,:,:,1)
sevc1_new(:,:,:,2)=sevc1_new(:,:,:,1)
endif
LR_iteration=1
ENDIF
LR_iteration=1
!Debugging
if (lr_verbosity >10) then
IF (lr_verbosity >10) THEN
!write(stdout,'("evc1_new(1), first step")')
!do ibnd=1,nbnd
! call check_vector_gamma(evc1_new(:,ibnd,1,1))
@ -130,7 +130,7 @@ contains
!write(stdout,'("sevc1_new(1), first step")')
!do ibnd=1,nbnd
! call check_vector_gamma(sevc1_new(:,ibnd,1,1))
!enddo
!enddo
!write(stdout,'("evc1_new(2), first step")')
!do ibnd=1,nbnd
! call check_vector_gamma(evc1_new(:,ibnd,1,2))
@ -140,9 +140,9 @@ contains
! call check_vector_gamma(sevc1_new(:,ibnd,1,2))
!enddo
temp=dble(lr_dot(evc1_new(1,1,1,1),sevc1_new(1,1,1,2)))
write(stdout,'("<evc1_new(1)|sevc1_new(2)> first step",E15.8)') temp
endif
endif
WRITE(stdout,'("<evc1_new(1)|sevc1_new(2)> first step",E15.8)') temp
ENDIF
ENDIF
!
! The lanczos algorithm starts here
! http://www.cs.utk.edu/~dongarra/etemplates/node245.html
@ -152,87 +152,87 @@ contains
!OBM: Notice that here "orthogonalization" is not strictly the true word, as the norm of the vectors change
!This is due to how the uspp scheme is implemented, the beta are evc1_new(left).sevc1_new(right), that is,
!a mixing of two vectors, thus the resultant vector from belov should be devoid from S, which affects the norm
!the modification in lr_ortho subroutine handles this reversal (the last flag).
do ik=1, nks
call lr_ortho(evc1_new(:,:,ik,1), evc0(:,:,ik), ik, ik, sevc0(:,:,ik),.true.)
call lr_ortho(evc1_new(:,:,ik,2), evc0(:,:,ik), ik, ik, sevc0(:,:,ik),.true.)
enddo
if (lr_verbosity >10) then
!the modification in lr_ortho subroutine handles this reversal (the last flag).
DO ik=1, nks
CALL lr_ortho(evc1_new(:,:,ik,1), evc0(:,:,ik), ik, ik, sevc0(:,:,ik),.true.)
CALL lr_ortho(evc1_new(:,:,ik,2), evc0(:,:,ik), ik, ik, sevc0(:,:,ik),.true.)
ENDDO
IF (lr_verbosity >10) THEN
temp=dble(lr_dot(evc1_new(1,1,1,1),sevc0(1,1,1)))
write(stdout,'("<evc1_new(1)|sevc0>",E15.8)') temp
WRITE(stdout,'("<evc1_new(1)|sevc0>",E15.8)') temp
temp=dble(lr_dot(evc1_new(1,1,1,2),sevc0(1,1,1)))
write(stdout,'("<evc1_new(2)|sevc0>",E15.8)') temp
endif
WRITE(stdout,'("<evc1_new(2)|sevc0>",E15.8)') temp
ENDIF
!
! By construction <p|Lq>=0 should be 0, forcing this both conserves resources and increases stability
alpha=0.0d0
alpha_store(pol_index,LR_iteration) = alpha
write(stdout,'(5X,"alpha(",i8.8,")=",e21.15)') LR_iteration,alpha
WRITE(stdout,'(5X,"alpha(",i8.8,")=",e21.15)') LR_iteration,alpha
!
if ( gamma_only ) then
!
if ( nkb >0 ) then
IF ( gamma_only ) THEN
!
IF ( nkb >0 ) THEN
!
if (real_space_debug>5) then
! real space & nkb > 0
IF (real_space_debug>5) THEN
! real space & nkb > 0
!
!
! The following part converts evc1_new(:,:,1,2) to real space
! then performs ccalbecr (rbecp calculation in real space)
!
do ibnd=1,nbnd,2
!
DO ibnd=1,nbnd,2
!
!
!
call fft_orbital_gamma(evc1_new(:,:,1,2),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp%r)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(sevc1_new(:,:,1,2),ibnd,nbnd)
CALL fft_orbital_gamma(evc1_new(:,:,1,2),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp%r)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(sevc1_new(:,:,1,2),ibnd,nbnd)
!
!
!
enddo
ENDDO
!
!
!
else
ELSE
! nkb > 0 & not real space
!
!
!
call calbec(npw,vkb,evc1_new(:,:,1,2),becp)
call s_psi(npwx,npw,nbnd,evc1_new(1,1,1,2),sevc1_new(1,1,1,2))
CALL calbec(npw,vkb,evc1_new(:,:,1,2),becp)
CALL s_psi(npwx,npw,nbnd,evc1_new(1,1,1,2),sevc1_new(1,1,1,2))
!
!
!
endif
ENDIF
!
!
else
! nkb = 0, (not an us pp)
ELSE
! nkb = 0, (not an us pp)
!
! This line just copies the array, leave it alone
call s_psi(npwx,npw,nbnd,evc1_new(1,1,1,2),sevc1_new(1,1,1,2))
CALL s_psi(npwx,npw,nbnd,evc1_new(1,1,1,2),sevc1_new(1,1,1,2))
!
!
!
!
endif
else
ENDIF
ELSE
!This is the generalised K point part
!
do ik=1,nks
DO ik=1,nks
!
if ( nkb > 0 .and. okvan ) then
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
call calbec(npw_k(ik),vkb,evc1_new(:,:,ik,2),becp)
end if
IF ( nkb > 0 .and. okvan ) THEN
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL calbec(npw_k(ik),vkb,evc1_new(:,:,ik,2),becp)
ENDIF
!
call s_psi(npwx,npw_k(ik),nbnd,evc1_new(1,1,ik,2),sevc1_new(1,1,ik,2))
CALL s_psi(npwx,npw_k(ik),nbnd,evc1_new(1,1,ik,2),sevc1_new(1,1,ik,2))
!
end do
ENDDO
!
end if
ENDIF
!print *, "norm of sevc1,1 after spsi", lr_dot(sevc1_new(1,1,1,1),sevc1_new(1,1,1,1))
!print *, "norm of sevc1,2 after spsi", lr_dot(sevc1_new(1,1,1,1),sevc1_new(1,1,1,2))
!Resume the LR
@ -241,124 +241,124 @@ contains
beta=dble(lr_dot(evc1_new(1,1,1,1),sevc1_new(1,1,1,2)))
!
!
if ( abs(beta)<1.0d-12 ) then
IF ( abs(beta)<1.0d-12 ) THEN
!
write(stdout,'(5x,"lr_lanczos: Left and right Lanczos vectors are orthogonal, this is a violation of oblique projection")')
WRITE(stdout,'(5x,"lr_lanczos: Left and right Lanczos vectors are orthogonal, this is a violation of oblique projection")')
!
else if ( beta<0.0d0 ) then
ELSEIF ( beta<0.0d0 ) THEN
!
beta=sqrt(-beta)
gamma=-beta
!
else if ( beta>0.0d0 ) then
ELSEIF ( beta>0.0d0 ) THEN
!
beta=sqrt(beta)
gamma=beta
!
endif
ENDIF
!
!
if (ionode) then
if ( charge_response == 1 .and. lr_verbosity > 0) then
!
IF (ionode) THEN
IF ( charge_response == 1 .and. lr_verbosity > 0) THEN
!print *, "beta=",beta,"w_T_beta_store", w_T_beta_store(LR_iteration)
write (stdout,'(5x,"(calc=",e21.15," read=",e21.15,")")') beta, w_T_beta_store(LR_iteration)
write (stdout,'(5x,"Weight for this step=",2(e11.5,1x))') w_T(LR_iteration)
endif
endif
WRITE (stdout,'(5x,"(calc=",e21.15," read=",e21.15,")")') beta, w_T_beta_store(LR_iteration)
WRITE (stdout,'(5x,"Weight for this step=",2(e11.5,1x))') w_T(LR_iteration)
ENDIF
ENDIF
beta_store (pol_index,LR_iteration) = beta
gamma_store(pol_index,LR_iteration) = gamma
write(stdout,'(5X,"beta (",i8.8,")=",e21.15)') LR_iteration+1,beta
write(stdout,'(5X,"gamma(",i8.8,")=",e21.15)') LR_iteration+1,gamma
if (lr_verbosity > 3) then
if ( LR_iteration > 6 ) then
write(stdout,'(5X,"(oscillatory variation) : ",f6.2,"%")') abs(100*(beta_store(pol_index,LR_iteration)- &
WRITE(stdout,'(5X,"beta (",i8.8,")=",e21.15)') LR_iteration+1,beta
WRITE(stdout,'(5X,"gamma(",i8.8,")=",e21.15)') LR_iteration+1,gamma
IF (lr_verbosity > 3) THEN
IF ( LR_iteration > 6 ) THEN
WRITE(stdout,'(5X,"(oscillatory variation) : ",f6.2,"%")') abs(100*(beta_store(pol_index,LR_iteration)- &
(beta_store(pol_index,LR_iteration-6)+beta_store(pol_index,LR_iteration-4)+ &
beta_store(pol_index,LR_iteration-2))/3.0)/beta_store(pol_index,LR_iteration))
write(stdout,'(5X,"(linear variation) : ",f6.2,"%")') abs(100*(beta_store(pol_index,LR_iteration)- &
WRITE(stdout,'(5X,"(linear variation) : ",f6.2,"%")') abs(100*(beta_store(pol_index,LR_iteration)- &
(beta_store(pol_index,LR_iteration-3)+beta_store(pol_index,LR_iteration-2)+ &
beta_store(pol_index,LR_iteration-1))/3.0)/beta_store(pol_index,LR_iteration))
endif
endif
!
ENDIF
ENDIF
!
!Since beta and gamma are known now, we can calculate the proper q from qdash
! V matrix is reset for a new step. Notice that evc1_old and evc1 are scaled so that they are q and p
! however evc1_new is qdash and pdash
!OBM, lets try BLAS
call zcopy(size_evc*2,evc1(:,:,:,:),1,evc1_old(:,:,:,:),1) !evc1_old = evc1
call zcopy(size_evc*2,evc1_new(:,:,:,:),1,evc1(:,:,:,:),1) !evc1 = evc1_new
CALL zcopy(size_evc*2,evc1(:,:,:,:),1,evc1_old(:,:,:,:),1) !evc1_old = evc1
CALL zcopy(size_evc*2,evc1_new(:,:,:,:),1,evc1(:,:,:,:),1) !evc1 = evc1_new
!
call zscal(size_evc,cmplx(1.0d0/beta,0.0d0,kind=dp),evc1(1,1,1,1),1)
call zscal(size_evc,cmplx(1.0d0/gamma,0.0d0,kind=dp),evc1(1,1,1,2),1)
CALL zscal(size_evc,cmplx(1.0d0/beta,0.0d0,kind=dp),evc1(1,1,1,1),1)
CALL zscal(size_evc,cmplx(1.0d0/gamma,0.0d0,kind=dp),evc1(1,1,1,2),1)
!
evc1_new(:,:,:,:)=(0.0d0,0.0d0)
sevc1_new(:,:,:,:)=(0.0d0,0.0d0)
!
if (lr_verbosity >10) then
write(stdout,'("evc1(1), rotate")')
do ibnd=1,nbnd
call check_vector_gamma(evc1(:,ibnd,1,1))
enddo
write(stdout,'("evc1(2), rotate")')
do ibnd=1,nbnd
call check_vector_gamma(evc1(:,ibnd,1,2))
enddo
endif
IF (lr_verbosity >10) THEN
WRITE(stdout,'("evc1(1), rotate")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1(:,ibnd,1,1))
ENDDO
WRITE(stdout,'("evc1(2), rotate")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1(:,ibnd,1,2))
ENDDO
ENDIF
!
!
if(.not.ltammd) then
!
if ( mod(LR_iteration,2)==0 ) then
call lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.false.)
call lr_apply_liouvillian(evc1(1,1,1,2),evc1_new(1,1,1,2),sevc1_new(1,1,1,2),.true.)
else
call lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.true.)
call lr_apply_liouvillian(evc1(1,1,1,2),evc1_new(1,1,1,2),sevc1_new(1,1,1,2),.false.)
end if
IF(.not.ltammd) THEN
!
else
call lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.true.)
call zcopy(size_evc,evc1(:,:,:,1),1,evc1(:,:,:,2),1) !evc1(,1) = evc1(,2)
call zcopy(size_evc,evc1_new(:,:,:,1),1,evc1_new(:,:,:,2),1) !evc1_new(,1) = evc1_new(,2)
call zcopy(size_evc,evc1_new(:,:,:,1),1,evc1_new(:,:,:,2),1) !evc1_new(,1) = evc1_new(,2)
end if
if (lr_verbosity >10) then
write(stdout,'("evc1(1), apply L")')
do ibnd=1,nbnd
call check_vector_gamma(evc1_new(:,ibnd,1,1))
enddo
write(stdout,'("evc1(2), apply L")')
do ibnd=1,nbnd
call check_vector_gamma(evc1_new(:,ibnd,1,2))
enddo
endif
IF ( mod(LR_iteration,2)==0 ) THEN
CALL lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.false.)
CALL lr_apply_liouvillian(evc1(1,1,1,2),evc1_new(1,1,1,2),sevc1_new(1,1,1,2),.true.)
ELSE
CALL lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.true.)
CALL lr_apply_liouvillian(evc1(1,1,1,2),evc1_new(1,1,1,2),sevc1_new(1,1,1,2),.false.)
ENDIF
!
ELSE
CALL lr_apply_liouvillian(evc1(1,1,1,1),evc1_new(1,1,1,1),sevc1_new(1,1,1,1),.true.)
CALL zcopy(size_evc,evc1(:,:,:,1),1,evc1(:,:,:,2),1) !evc1(,1) = evc1(,2)
CALL zcopy(size_evc,evc1_new(:,:,:,1),1,evc1_new(:,:,:,2),1) !evc1_new(,1) = evc1_new(,2)
CALL zcopy(size_evc,evc1_new(:,:,:,1),1,evc1_new(:,:,:,2),1) !evc1_new(,1) = evc1_new(,2)
ENDIF
IF (lr_verbosity >10) THEN
WRITE(stdout,'("evc1(1), apply L")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1_new(:,ibnd,1,1))
ENDDO
WRITE(stdout,'("evc1(2), apply L")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1_new(:,ibnd,1,2))
ENDDO
ENDIF
!
! qdash(i+1)=f(q(i))-gamma*q(i-1)
! pdash(i+1)=f(p(i))-beta*p(i-1)
! where f(p(i)) or f(q(i)) are calculated by lr_apply_liovillian
! pdash(i+1)=f(p(i))-beta*p(i-1)
! where f(p(i)) or f(q(i)) are calculated by lr_apply_liovillian
!
!OBM BLAS
call zaxpy(size_evc,-cmplx(gamma,0.0d0,kind=dp),evc1_old(:,:,:,1),1,evc1_new(:,:,:,1),1)
call zaxpy(size_evc,-cmplx(beta,0.0d0,kind=dp),evc1_old(:,:,:,2),1,evc1_new(:,:,:,2),1)
if (lr_verbosity >10) then
write(stdout,'("evc1(1), final")')
do ibnd=1,nbnd
call check_vector_gamma(evc1_new(:,ibnd,1,1))
enddo
write(stdout,'("evc1(2), final")')
do ibnd=1,nbnd
call check_vector_gamma(evc1_new(:,ibnd,1,2))
enddo
endif
CALL zaxpy(size_evc,-cmplx(gamma,0.0d0,kind=dp),evc1_old(:,:,:,1),1,evc1_new(:,:,:,1),1)
CALL zaxpy(size_evc,-cmplx(beta,0.0d0,kind=dp),evc1_old(:,:,:,2),1,evc1_new(:,:,:,2),1)
IF (lr_verbosity >10) THEN
WRITE(stdout,'("evc1(1), final")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1_new(:,ibnd,1,1))
ENDDO
WRITE(stdout,'("evc1(2), final")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1_new(:,ibnd,1,2))
ENDDO
ENDIF
!
call stop_clock('one_step')
CALL stop_clock('one_step')
!
return
RETURN
!
end subroutine one_lanczos_step
END SUBROUTINE one_lanczos_step
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module lr_lanczos
END MODULE lr_lanczos

384
TDDFPT/src/lr_main.f90
View File

@ -32,9 +32,9 @@ PROGRAM lr_main
USE ions_base, ONLY : tau,nat,atm,ityp
USE environment, ONLY: environment_start
USE mp_global, ONLY : nimage, mp_startup
USE control_ph, ONLY : nbnd_occ
use wvfct, only : nbnd
USE wvfct, ONLY : nbnd
USE wavefunctions_module, ONLY : psic
!Debugging
USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,check_vector_gamma
@ -48,7 +48,7 @@ PROGRAM lr_main
INTEGER :: iter_restart,iteration
LOGICAL :: rflag
CHARACTER (len=9) :: code = 'TDDFPT'
complex(kind=dp) :: sum_F,sum_c
COMPLEX(kind=dp) :: sum_F,sum_c
!
!
pol_index=1
@ -67,18 +67,18 @@ PROGRAM lr_main
! WRITE( stdout, '(/5x,"Please cite this project as: ")' )
! WRITE( stdout, '(/5x,"O.B.Malcioglu, R. Gebauer, D. Rocca, S. Baroni,")' )
! WRITE( stdout, '(/5x,"""turboTDDFT – a code for the simulation of molecular")' )
! WRITE( stdout, '(/5x,"spectra using the Liouville-Lanczos approach to")' )
! WRITE( stdout, '(/5x,"spectra using the Liouville-Lanczos approach to")' )
! WRITE( stdout, '(/5x,"time-dependent density-functional perturbation theory""")' )
! WRITE( stdout, '(/5x,"CPC, (in press)")' )
WRITE( stdout, '(/5x,"----------------------------------------")' )
!
CALL start_clock('lr_main')
!
WRITE( stdout, '(/5x,"Ultrasoft (Vanderbilt) Pseudopotentials")' )
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_main>")')
endif
ENDIF
!
! Reading input file and PWSCF xml, some initialisation
!
@ -93,89 +93,89 @@ PROGRAM lr_main
! Allocate and zero lr variables
!
!OBM_DEBUG
If (lr_verbosity > 6) THEN
IF (lr_verbosity > 6) THEN
WRITE(stdout,'(/,5X,"Step-main1")')
endif
ENDIF
!OBM_DEBUG
!
!
!Initialisation of degauss/openshell related stuff
!
call lr_init_nfo()
if (project) then
if(nbnd > nbnd_occ(1)) then
CALL lr_init_nfo()
IF (project) THEN
IF(nbnd > nbnd_occ(1)) THEN
WRITE(stdout,'(/,5X,"Virtual states in ground state run will be used in projection analysis")')
else
ELSE
WRITE(stdout,'(/,5X,"No virtual states for projection found")')
project=.false.
endif
endif
ENDIF
ENDIF
IF (nbnd>nbnd_occ(1)) then
IF (nbnd>nbnd_occ(1)) THEN
WRITE(stdout,'(/,5X,"Warning: There are virtual states in the input file, trying to disregard in response calculation")')
nbnd_total=nbnd
nbnd=nbnd_occ(1)
else
ELSE
nbnd_total=nbnd
endif
ENDIF
!
CALL lr_alloc_init()
CALL lr_alloc_init()
!
! Charge response: initialisation
!
!
! Read in ground state wavefunctions
!
!
!OBM_DEBUG
If (lr_verbosity > 6) THEN
IF (lr_verbosity > 6) THEN
WRITE(stdout,'(/,5X,"Step-main2")')
endif
ENDIF
!OBM_DEBUG
CALL lr_read_wf()
!
! Set up initial response orbitals
!
!OBM_DEBUG
If (lr_verbosity > 6) THEN
IF (lr_verbosity > 6) THEN
WRITE(stdout,'(/,5X,"Step-main3")')
endif
ENDIF
!OBM_DEBUG
!
IF ( test_restart(1) ) then
IF ( test_restart(1) ) THEN
CALL lr_read_d0psi()
else
ELSE
CALL lr_solve_e()
endif
ENDIF
DEALLOCATE( psic )
DEALLOCATE( psic )
if(project) then
IF(project) THEN
CALL sd0psi() !after this d0psi is Sd0psi the d0psi is read afterwards again...
call lr_calc_R()
CALL lr_calc_R()
DO ip=1, n_ipol
write(stdout,'(/,/5x,"Oscillator strengths for polarization direction",1x,i8)') ip
write(stdout,'(5x,"occ",1x,"con",8x,"Re(R)",14x,"Im(R)")')
do ibnd_occ=1,nbnd
do ibnd_virt=1,(nbnd_total-nbnd)
write(stdout,'(5x,i3,1x,i3,3x,E16.8,2X,E16.8)') &
ibnd_occ,ibnd_virt,DBLE(R(ibnd_occ,ibnd_virt,ip)),AIMAG(R(ibnd_occ,ibnd_virt,ip))
enddo
enddo
enddo
endif
WRITE(stdout,'(/,/5x,"Oscillator strengths for polarization direction",1x,i8)') ip
WRITE(stdout,'(5x,"occ",1x,"con",8x,"Re(R)",14x,"Im(R)")')
DO ibnd_occ=1,nbnd
DO ibnd_virt=1,(nbnd_total-nbnd)
WRITE(stdout,'(5x,i3,1x,i3,3x,E16.8,2X,E16.8)') &
ibnd_occ,ibnd_virt,dble(R(ibnd_occ,ibnd_virt,ip)),aimag(R(ibnd_occ,ibnd_virt,ip))
ENDDO
ENDDO
ENDDO
ENDIF
!
! Set up initial stuff for derivatives
!
!OBM_DEBUG
If (lr_verbosity > 6) THEN
IF (lr_verbosity > 6) THEN
WRITE(stdout,'(/,5X,"Step-main4")')
endif
ENDIF
!OBM_DEBUG
CALL lr_dv_setup()
!OBM_DEBUG
If (lr_verbosity > 6) THEN
IF (lr_verbosity > 6) THEN
WRITE(stdout,'(/,5X,"Step-main5")')
endif
ENDIF
!OBM_DEBUG
!Coordinates of the read atom, just in case
IF (lr_verbosity > 1) THEN
@ -188,30 +188,30 @@ PROGRAM lr_main
! Lanczos loop where the real work happens
!
DO ip=1, n_ipol
if (n_ipol/=1) then
IF (n_ipol/=1) THEN
LR_polarization=ip
pol_index=LR_polarization
endif
!
if (charge_response == 1 ) then
ENDIF
!
IF (charge_response == 1 ) THEN
!
! Read precalculated beta gamma z
!
call read_wT_beta_gamma_z()
call lr_calc_w_T()
endif
CALL read_wT_beta_gamma_z()
CALL lr_calc_w_T()
ENDIF
!
!
IF (test_restart(2)) then
IF (test_restart(2)) THEN
!
!
CALL lr_restart(iter_restart,rflag)
CALL lr_read_d0psi()
!
write(stdout,'(/5x,"Restarting Lanczos loop",1x,i8)') LR_polarization
WRITE(stdout,'(/5x,"Restarting Lanczos loop",1x,i8)') LR_polarization
!
else
!
ELSE
!
!
CALL lr_read_d0psi()
evc1(:,:,:,1) = d0psi(:,:,:,pol_index)
@ -220,113 +220,113 @@ PROGRAM lr_main
!
iter_restart=1
!
write(stdout,'(/5x,"Starting Lanczos loop",1x,i8)') LR_polarization
!
END IF
if (lr_verbosity >10) then
write(stdout,'("d0psi")')
do ibnd=1,nbnd
call check_vector_gamma(d0psi(:,ibnd,1,pol_index))
enddo
endif
WRITE(stdout,'(/5x,"Starting Lanczos loop",1x,i8)') LR_polarization
!
ENDIF
IF (lr_verbosity >10) THEN
WRITE(stdout,'("d0psi")')
DO ibnd=1,nbnd
CALL check_vector_gamma(d0psi(:,ibnd,1,pol_index))
ENDDO
ENDIF
!
!
CALL sd0psi() !after this d0psi is Sd0psi !OBM:Check if this is really necessary
!
!
if (lr_verbosity >10) then
write(stdout,'("initial evc1")')
do ibnd=1,nbnd
call check_vector_gamma(evc1(:,ibnd,1,1))
enddo
write(stdout,'("initial sd0psi")')
do ibnd=1,nbnd
call check_vector_gamma(d0psi(:,ibnd,1,pol_index))
enddo
endif
IF (lr_verbosity >10) THEN
WRITE(stdout,'("initial evc1")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc1(:,ibnd,1,1))
ENDDO
WRITE(stdout,'("initial sd0psi")')
DO ibnd=1,nbnd
CALL check_vector_gamma(d0psi(:,ibnd,1,pol_index))
ENDDO
ENDIF
!
lancz_loop1 : DO iteration = iter_restart, itermax
!
LR_iteration=iteration
write(stdout,'(/5x,"Lanczos iteration:",1x,i8)') LR_iteration
WRITE(stdout,'(/5x,"Lanczos iteration:",1x,i8)') LR_iteration
!
call one_lanczos_step()
CALL one_lanczos_step()
!
IF ( lr_io_level > 0 .and. (mod(LR_iteration,restart_step)==0 .OR. &
LR_iteration==itermax .OR. LR_iteration==1) )&
IF ( lr_io_level > 0 .and. (mod(LR_iteration,restart_step)==0 .or. &
LR_iteration==itermax .or. LR_iteration==1) )&
CALL lr_write_restart()
END DO lancz_loop1
!
ENDDO lancz_loop1
!
if (charge_response == 1 ) then
if (resonance_condition) then
IF (charge_response == 1 ) THEN
IF (resonance_condition) THEN
!response charge density, absorbtive
if (plot_type == 1 .or. plot_type == 5) &
call lr_dump_rho_tot_xyzd(aimag(rho_1_tot_im(:,1)),"absorbtive")
if (plot_type == 2 .or. plot_type == 5) &
call lr_dump_rho_tot_xcrys(aimag(rho_1_tot_im(:,1)),"absorbtive")
if (plot_type == 3 .or. plot_type == 5) &
call lr_dump_rho_tot_cube(aimag(rho_1_tot_im(:,1)),"absorbtive")
IF (plot_type == 1 .or. plot_type == 5) &
CALL lr_dump_rho_tot_xyzd(aimag(rho_1_tot_im(:,1)),"absorbtive")
IF (plot_type == 2 .or. plot_type == 5) &
CALL lr_dump_rho_tot_xcrys(aimag(rho_1_tot_im(:,1)),"absorbtive")
IF (plot_type == 3 .or. plot_type == 5) &
CALL lr_dump_rho_tot_cube(aimag(rho_1_tot_im(:,1)),"absorbtive")
!response charge density, dispersive
if (plot_type == 1 .or. plot_type == 5) &
call lr_dump_rho_tot_xyzd(dble(rho_1_tot_im(:,1)),"dispersive")
if (plot_type == 2 .or. plot_type == 5) &
call lr_dump_rho_tot_xcrys(dble(rho_1_tot_im(:,1)),"dispersive")
if (plot_type == 3 .or. plot_type == 5) &
call lr_dump_rho_tot_cube(dble(rho_1_tot_im(:,1)),"dispersive")
else
if (plot_type == 1 .or. plot_type == 5) call lr_dump_rho_tot_xyzd(rho_1_tot(:,1),"summed-rho")
if (plot_type == 2 .or. plot_type == 5) call lr_dump_rho_tot_xcrys(rho_1_tot(:,1),"summed-rho")
if (plot_type == 3 .or. plot_type == 5) call lr_dump_rho_tot_cube(rho_1_tot(:,1),"summed-rho")
endif
endif
if (project) then
write(stdout,'(/,/5x,"Projection of virtual states for polarization direction",1x,i8)') LR_polarization
write(stdout,'(2x,"occ",1x,"vir",8x,"Re(F)",14x,"Im(F)",8x, &
IF (plot_type == 1 .or. plot_type == 5) &
CALL lr_dump_rho_tot_xyzd(dble(rho_1_tot_im(:,1)),"dispersive")
IF (plot_type == 2 .or. plot_type == 5) &
CALL lr_dump_rho_tot_xcrys(dble(rho_1_tot_im(:,1)),"dispersive")
IF (plot_type == 3 .or. plot_type == 5) &
CALL lr_dump_rho_tot_cube(dble(rho_1_tot_im(:,1)),"dispersive")
ELSE
IF (plot_type == 1 .or. plot_type == 5) CALL lr_dump_rho_tot_xyzd(rho_1_tot(:,1),"summed-rho")
IF (plot_type == 2 .or. plot_type == 5) CALL lr_dump_rho_tot_xcrys(rho_1_tot(:,1),"summed-rho")
IF (plot_type == 3 .or. plot_type == 5) CALL lr_dump_rho_tot_cube(rho_1_tot(:,1),"summed-rho")
ENDIF
ENDIF
IF (project) THEN
WRITE(stdout,'(/,/5x,"Projection of virtual states for polarization direction",1x,i8)') LR_polarization
WRITE(stdout,'(2x,"occ",1x,"vir",8x,"Re(F)",14x,"Im(F)",8x, &
& " Frac. pres. in Re(chi_",I1,"_",I1,") and Im(chi_",I1,"_",I1,")")') &
& ip,ip,ip,ip
sum_f=cmplx(0.0d0,0.0d0,dp)
do ibnd_occ=1,nbnd
do ibnd_virt=1,(nbnd_total-nbnd)
DO ibnd_occ=1,nbnd
DO ibnd_virt=1,(nbnd_total-nbnd)
F(ibnd_occ,ibnd_virt,ip)=F(ibnd_occ,ibnd_virt,ip)*cmplx(w_T_norm0_store,0.0d0,dp)
sum_f=F(ibnd_occ,ibnd_virt,ip)*conjg(R(ibnd_occ,ibnd_virt,ip))
write(stdout,'(2x,i3,1x,i3,3x,E16.8,2X,E16.8,17X,F8.5,2x,F8.5)') &
ibnd_occ,ibnd_virt,DBLE(F(ibnd_occ,ibnd_virt,ip)),AIMAG(F(ibnd_occ,ibnd_virt,ip)),&
(dble(sum_f)/dble(chi(ip,ip))), (AIMAG(sum_f)/AIMAG(chi(ip,ip)))
enddo
enddo
endif
WRITE(stdout,'(2x,i3,1x,i3,3x,E16.8,2X,E16.8,17X,F8.5,2x,F8.5)') &
ibnd_occ,ibnd_virt,dble(F(ibnd_occ,ibnd_virt,ip)),aimag(F(ibnd_occ,ibnd_virt,ip)),&
(dble(sum_f)/dble(chi(ip,ip))), (aimag(sum_f)/aimag(chi(ip,ip)))
ENDDO
ENDDO
ENDIF
!
END DO
DEALLOCATE( revc0 )
ENDDO
DEALLOCATE( revc0 )
!
!
WRITE(stdout,'(5x,"End of Lanczos iterations")')
WRITE(stdout,'(5x,"End of Lanczos iterations")')
!
!Final reports
!
if (project .and. n_ipol == 3) then
write(stdout,'(/,/5x,"Participation of virtual states to absorbtion coefficent")')
write(stdout,'(5x,"occ",1x,"vir",5x,"Re(Tr(F.R))",6x,"Im(TR(F.R))",5x,"fraction in alpha")')
do ibnd_occ=1,nbnd
do ibnd_virt=1,(nbnd_total-nbnd)
IF (project .and. n_ipol == 3) THEN
WRITE(stdout,'(/,/5x,"Participation of virtual states to absorbtion coefficent")')
WRITE(stdout,'(5x,"occ",1x,"vir",5x,"Re(Tr(F.R))",6x,"Im(TR(F.R))",5x,"fraction in alpha")')
DO ibnd_occ=1,nbnd
DO ibnd_virt=1,(nbnd_total-nbnd)
sum_f=cmplx(0.0d0,0.0d0,dp)
sum_c=cmplx(0.0d0,0.0d0,dp)
do ip=1,n_ipol
DO ip=1,n_ipol
sum_f=sum_f+F(ibnd_occ,ibnd_virt,ip)*conjg(R(ibnd_occ,ibnd_virt,ip))
sum_c=sum_c+chi(ip,ip)
enddo
write(stdout,'(5x,i3,1x,i3,3x,E16.8,2X,E16.8,2X,F8.5)') &
ibnd_occ,ibnd_virt,DBLE(sum_F),AIMAG(sum_F),(AIMAG(sum_f)/AIMAG(sum_c))
enddo
enddo
endif
ENDDO
WRITE(stdout,'(5x,i3,1x,i3,3x,E16.8,2X,E16.8,2X,F8.5)') &
ibnd_occ,ibnd_virt,dble(sum_F),aimag(sum_F),(aimag(sum_f)/aimag(sum_c))
ENDDO
ENDDO
ENDIF
!
! Deallocate pw variables
!
CALL clean_pw( .FALSE. )
CALL clean_pw( .false. )
!
WRITE(stdout,'(5x,"Finished linear response calculation...")')
!
@ -336,9 +336,9 @@ PROGRAM lr_main
!
CALL stop_lr()
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<end of lr_main>")')
endif
ENDIF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Additional small-time subroutines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -347,126 +347,126 @@ CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!This tests whether the restart flag is applicable
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
use lr_variables, only : n_ipol,LR_polarization,restart,bgz_suffix
use io_files, only: prefix, tmp_dir, nd_nmbr, wfc_dir
USE lr_variables, ONLY : n_ipol,LR_polarization,restart,bgz_suffix
USE io_files, ONLY: prefix, tmp_dir, nd_nmbr, wfc_dir
USE mp, ONLY : mp_bcast, mp_barrier,mp_sum
USE io_global, ONLY : ionode, ionode_id
IMPLICIT NONE
integer, intent(in) :: test_this
character(len=256) :: tempfile, filename, tmp_dir_saved
logical :: exst
character(len=6), external :: int_to_char
integer :: i, temp_restart
INTEGER, INTENT(in) :: test_this
CHARACTER(len=256) :: tempfile, filename, tmp_dir_saved
LOGICAL :: exst
CHARACTER(len=6), EXTERNAL :: int_to_char
INTEGER :: i, temp_restart
!
!test_this= 1 : d0psi files
!test_this= 2 : lanczos restart files
!test_this= 1 : d0psi files
!test_this= 2 : lanczos restart files
temp_restart=0
!print *, "test_restart with restart=",restart
if (.not.restart) then
IF (.not.restart) THEN
test_restart = .false.
return
endif
RETURN
ENDIF
test_restart=.true.
if (test_this == 1) then
IF (test_this == 1) THEN
!
!Check for parallel i/o files that are in wfc_dir
tmp_dir_saved = tmp_dir
IF ( wfc_dir /= 'undefined' ) tmp_dir = wfc_dir
!
if ( n_ipol == 1 ) then
IF ( n_ipol == 1 ) THEN
filename = trim(prefix)//'.d0psi.'//trim(int_to_char(1))
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
inquire (file = tempfile, exist = exst)
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
INQUIRE (file = tempfile, exist = exst)
!print *, tempfile," exst=",exst
if (.not. exst) then
IF (.not. exst) THEN
temp_restart=1
endif
else
ENDIF
ELSE
DO i=1, n_ipol
filename = trim(prefix)//'.d0psi.'//trim(int_to_char(i))
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
inquire (file = tempfile, exist = exst)
INQUIRE (file = tempfile, exist = exst)
!print *, tempfile," exst=",exst
if (.not. exst) then
IF (.not. exst) THEN
temp_restart=1
endif
END DO
endif
ENDIF
ENDDO
ENDIF
tmp_dir = tmp_dir_saved
IF ( wfc_dir /= 'undefined' ) then
IF ( wfc_dir /= 'undefined' ) THEN
! check if these files can be read from outdir instead of wfcdir
!
if ( n_ipol == 1 ) then
IF ( n_ipol == 1 ) THEN
filename = trim(prefix)//'.d0psi.'//trim(int_to_char(1))
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
inquire (file = tempfile, exist = exst)
if (exst) then
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
INQUIRE (file = tempfile, exist = exst)
IF (exst) THEN
temp_restart=0
endif
else
ENDIF
ELSE
DO i=1, n_ipol
filename = trim(prefix)//'.d0psi.'//trim(int_to_char(i))
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
inquire (file = tempfile, exist = exst)
if (exst) then
INQUIRE (file = tempfile, exist = exst)
IF (exst) THEN
temp_restart=0
endif
END DO
endif
endif
endif !for test_this = 1
if (test_this == 2) then
ENDIF
ENDDO
ENDIF
ENDIF
ENDIF !for test_this = 1
IF (test_this == 2) THEN
!Restart files are always written in outdir
if ( n_ipol == 1 ) then
IF ( n_ipol == 1 ) THEN
filename = trim(prefix)//'.restart_lanczos.'//trim(int_to_char(1))
tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr
else
ELSE
filename = trim(prefix)//'.restart_lanczos.'//trim(int_to_char(LR_polarization))
tempfile = trim(tmp_dir) // trim(filename)//nd_nmbr
endif
inquire (file = tempfile, exist = exst)
ENDIF
INQUIRE (file = tempfile, exist = exst)
!print *, tempfile," exst=",exst
if (.not. exst) then
IF (.not. exst) THEN
temp_restart=1
endif
ENDIF
!
!End of parallel file i/o
!
if ( n_ipol == 1 ) then
IF ( n_ipol == 1 ) THEN
filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(1))
tempfile = trim(tmp_dir) // trim(filename)
else
ELSE
filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(LR_polarization))
tempfile = trim(tmp_dir) // trim(filename)
endif
inquire (file = tempfile, exist = exst)
ENDIF
INQUIRE (file = tempfile, exist = exst)
!print *, tempfile," exst=",exst
if (.not. exst) then
IF (.not. exst) THEN
temp_restart=1
endif
endif !for test_this = 2
ENDIF
ENDIF !for test_this = 2
!print *,"temp_restart",temp_restart
#ifdef __PARA
call mp_sum(temp_restart)
CALL mp_sum(temp_restart)
#endif
!print *, "current temp_restart", temp_restart
if (temp_restart > 0 ) then
IF (temp_restart > 0 ) THEN
!print *,"restart falsified",nd_nmbr
!WRITE(stdout,'(5X,A,3X,"is missing, unable to restart.")') offender
WRITE(stdout,'(5X,"There are missing files!")')
if (test_this==1) WRITE(stdout,'(5X,"d0psi files can not be found,trying to recompansate")')
if (test_this==2) WRITE(stdout,'(5X,"lanczos restart files can not be found, starting run from scratch")')
IF (test_this==1) WRITE(stdout,'(5X,"d0psi files can not be found,trying to recompansate")')
IF (test_this==2) WRITE(stdout,'(5X,"lanczos restart files can not be found, starting run from scratch")')
test_restart=.false.
endif
RETURN
ENDIF
RETURN
END FUNCTION test_restart
END PROGRAM lr_main
!-----------------------------------------------------------------------

142
TDDFPT/src/lr_normalise.f90
View File

@ -3,53 +3,53 @@
! ... have an inner product of 1
!-----------------------------------------------------------------------
! Modified by Osman Baris Malcioglu (2009)
subroutine lr_normalise(evc1,norm)
SUBROUTINE lr_normalise(evc1,norm)
!
#include "f_defs.h"
!
use gvect, only : gstart
use cell_base, only : omega
use io_global, only : stdout
use kinds, only : dp
use klist, only : nks,xk
use lsda_mod, only : nspin
use lr_variables, only : lanc_norm
use realus, only : igk_k,npw_k
use uspp, only : vkb,nkb,okvan
use wvfct, only : nbnd,npwx,npw,wg
use control_flags, only : gamma_only
USE gvect, ONLY : gstart
USE cell_base, ONLY : omega
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE klist, ONLY : nks,xk
USE lsda_mod, ONLY : nspin
USE lr_variables, ONLY : lanc_norm
USE realus, ONLY : igk_k,npw_k
USE uspp, ONLY : vkb,nkb,okvan
USE wvfct, ONLY : nbnd,npwx,npw,wg
USE control_flags, ONLY : gamma_only
USE lr_variables, ONLY : lr_verbosity
!
implicit none
IMPLICIT NONE
!
real(kind=dp), intent(out) :: norm
real(kind=dp), INTENT(out) :: norm
!
! local variables
integer :: ik
complex(kind=dp) :: evc1(npwx,nbnd,nks)
complex(kind=dp), allocatable :: spsi(:,:,:)
integer :: ibnd,ig
INTEGER :: ik
COMPLEX(kind=dp) :: evc1(npwx,nbnd,nks)
COMPLEX(kind=dp), ALLOCATABLE :: spsi(:,:,:)
INTEGER :: ibnd,ig
!
allocate(spsi(npwx,nbnd,nks))
ALLOCATE(spsi(npwx,nbnd,nks))
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_normalise>")')
endif
if(gamma_only) then
call lr_normalise_gamma()
else
call lr_normalise_k()
endif
ENDIF
IF(gamma_only) THEN
CALL lr_normalise_gamma()
ELSE
CALL lr_normalise_k()
ENDIF
!
deallocate(spsi)
DEALLOCATE(spsi)
!
return
RETURN
!
contains
CONTAINS
!
subroutine lr_normalise_gamma()
SUBROUTINE lr_normalise_gamma()
!
use becmod, only : bec_type, becp,calbec
USE becmod, ONLY : bec_type, becp,calbec
!use lr_variables, only : real_space
!use real_beta, only : ccalbecr_gamma,s_psir,fft_orbital_gamma,bfft_orbital_gamma
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
@ -59,47 +59,47 @@ contains
!
!
!
implicit none
IMPLICIT NONE
!
real(kind=dp) :: prod
complex(kind=dp), external :: lr_dot
integer :: ibnd,ig
COMPLEX(kind=dp), EXTERNAL :: lr_dot
INTEGER :: ibnd,ig
!
prod=0.0d0
!
if ( nkb > 0 ) then
IF ( nkb > 0 ) THEN
!
if (real_space_debug>6) then
! real space & nkb > 0
IF (real_space_debug>6) THEN
! real space & nkb > 0
!
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc1(:,:,1),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp%r)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(spsi(:,:,1),ibnd,nbnd)
enddo
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc1(:,:,1),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp%r)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(spsi(:,:,1),ibnd,nbnd)
ENDDO
!
!
else
ELSE
!
!the non real_space & nkb > 0 case
!the non real_space & nkb > 0 case
!
call calbec(npw_k(1),vkb,evc1(:,:,1),becp)
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,evc1(1,1,1),npwx,rbecp,nkb)
CALL calbec(npw_k(1),vkb,evc1(:,:,1),becp)
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,evc1(1,1,1),npwx,rbecp,nkb)
!
call s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi)
CALL s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi)
!
!
endif
else
ENDIF
ELSE
! The nkb == 0 part
! JUST array copying
call s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi)
CALL s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi)
!
!
!
endif
!The below two lines are the replicated part in real space implementation
ENDIF
!The below two lines are the replicated part in real space implementation
!call calbec(npw_k(1),vkb,evc1(:,:,1),rbecp)
!call s_psi(npwx,npw_k(1),nbnd,evc1(1,1,1),spsi)
!
@ -108,49 +108,49 @@ contains
!
evc1(:,:,1)=cmplx(prod,0.0d0,dp)*evc1(:,:,1)
!
write(stdout,'(5X,"Norm of initial Lanczos vectors=",1x,f21.15)') 1.0d0/prod
WRITE(stdout,'(5X,"Norm of initial Lanczos vectors=",1x,f21.15)') 1.0d0/prod
lanc_norm=1.d0/prod**2/omega
norm=1.0d0/prod
!
return
end subroutine lr_normalise_gamma
RETURN
END SUBROUTINE lr_normalise_gamma
!
subroutine lr_normalise_k()
SUBROUTINE lr_normalise_k()
!
use becmod, only : becp,calbec
USE becmod, ONLY : becp,calbec
!
real(kind=dp) :: prod
complex(kind=dp), external :: lr_dot
COMPLEX(kind=dp), EXTERNAL :: lr_dot
!
prod=0.0d0
!
do ik=1,nks
DO ik=1,nks
!
if ( nkb > 0 .and. okvan) then
IF ( nkb > 0 .and. okvan) THEN
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!
!call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp,vkb,evc1(1,1,ik))
call calbec(npw_k(ik),vkb,evc1(:,:,ik),becp)
!call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp,vkb,evc1(1,1,ik))
CALL calbec(npw_k(ik),vkb,evc1(:,:,ik),becp)
!
endif
ENDIF
!
call s_psi(npwx,npw_k(ik),nbnd,evc1(:,:,ik),spsi(:,:,ik))
CALL s_psi(npwx,npw_k(ik),nbnd,evc1(:,:,ik),spsi(:,:,ik))
!
end do
ENDDO
!
prod=dble( lr_dot( evc1(1,1,1),spsi(1,1,1) ) )
prod=1.0d0/sqrt(abs(prod))
!
evc1(:,:,:)=cmplx(prod,0.0d0,dp)*evc1(:,:,:)
!
write(stdout,'(5X,"Norm of initial Lanczos vectors=",1x,f21.15)') 1.0d0/prod
WRITE(stdout,'(5X,"Norm of initial Lanczos vectors=",1x,f21.15)') 1.0d0/prod
lanc_norm=1.d0/prod**2/omega
norm=1.0d0/prod
!
return
RETURN
!
end subroutine lr_normalise_k
END SUBROUTINE lr_normalise_k
!
end subroutine lr_normalise
END SUBROUTINE lr_normalise
!-----------------------------------------------------------------------

162
TDDFPT/src/lr_ortho.f90
View File

@ -14,14 +14,14 @@ SUBROUTINE lr_ortho(dvpsi, evq, ikk, ikq, sevc, inverse)
!
!
! This routine ortogonalizes dvpsi to the valence states: ps = <evq|dvpsi>
! It should be quite general. It works for metals and insulators, with
! It should be quite general. It works for metals and insulators, with
! NC as well as with US PP, both SR or FR.
! Note that on output it changes sign. So it applies -P^+_c.
!
!OBM!! evc0 ->evq sevc0 -> sevc dvpsi -> input/output
!
USE kinds, ONLY : DP
use gvect, only : gstart
USE gvect, ONLY : gstart
USE klist, ONLY : lgauss, degauss, ngauss
USE noncollin_module, ONLY : noncolin, npol
USE wvfct, ONLY : npwx, nbnd, et
@ -32,78 +32,78 @@ USE control_ph, ONLY : alpha_pv, nbnd_occ
USE uspp, ONLY : vkb, okvan
USE mp_global, ONLY : intra_pool_comm
USE mp, ONLY : mp_sum
!use lr_variables, ONLY : lr_alpha_pv, nbnd_occ,
use lr_variables, ONLY : lr_verbosity
use realus, ONLY : npw_k
use control_flags, only : gamma_only
!use lr_variables, ONLY : lr_alpha_pv, nbnd_occ,
USE lr_variables, ONLY : lr_verbosity
USE realus, ONLY : npw_k
USE control_flags, ONLY : gamma_only
USE io_global, ONLY : stdout
!
IMPLICIT NONE
INTEGER, INTENT(IN) :: ikk, ikq ! the index of the k and k+q points
COMPLEX(DP), INTENT(IN) :: evq(npwx*npol,nbnd)
COMPLEX(DP), INTENT(INOUT) :: dvpsi(npwx*npol,nbnd)
COMPLEX(DP), INTENT(IN) :: sevc(npwx*npol,nbnd) ! work space allocated by
INTEGER, INTENT(in) :: ikk, ikq ! the index of the k and k+q points
COMPLEX(DP), INTENT(in) :: evq(npwx*npol,nbnd)
COMPLEX(DP), INTENT(inout) :: dvpsi(npwx*npol,nbnd)
COMPLEX(DP), INTENT(in) :: sevc(npwx*npol,nbnd) ! work space allocated by
! the calling routine (was called dpsi)
!real(kind=dp), intent(IN) :: lr_alpha_pv !This is calculated manually in tddfpt
logical, intent(in):: inverse !if .true. |dvspi> = |dvpsi> - |evq><sevc|dvpsi> instead of |dvspi> = |dvpsi> - |sevc><evq|dvpsi>
LOGICAL, INTENT(in):: inverse !if .true. |dvspi> = |dvpsi> - |evq><sevc|dvpsi> instead of |dvspi> = |dvpsi> - |sevc><evq|dvpsi>
logical:: inverse_mode
LOGICAL:: inverse_mode
! functions computing the delta and theta function
CALL start_clock ('lr_ortho')
If (lr_verbosity > 5) WRITE(stdout,'("<lr_ortho>")')
IF (lr_verbosity > 5) WRITE(stdout,'("<lr_ortho>")')
!
!if (.not. present(inverse)) then
!if (.not. present(inverse)) then
! inverse_mode=.false.
!else
inverse_mode=inverse
!endif
if (gamma_only) then
IF (gamma_only) THEN
!
call lr_ortho_gamma()
CALL lr_ortho_gamma()
!
else if (noncolin) then
ELSEIF (noncolin) THEN
!
call lr_ortho_noncolin()
CALL lr_ortho_noncolin()
!
else
ELSE
!
call lr_ortho_k()
CALL lr_ortho_k()
!
end if
ENDIF
CALL stop_clock ('lr_ortho')
RETURN
contains
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!multiple K point specific
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_ortho_k()
SUBROUTINE lr_ortho_k()
IMPLICIT NONE
COMPLEX(DP), ALLOCATABLE :: ps(:,:)
INTEGER :: ibnd, jbnd, nbnd_eff
REAL(DP) :: wg1, w0g, wgp, wwg, deltae, theta
REAL(DP), EXTERNAL :: w0gauss, wgauss
REAL(DP), EXTERNAL :: w0gauss, wgauss
ALLOCATE(ps(nbnd,nbnd))
!
if (lgauss) then
IF (lgauss) THEN
!
! metallic case
!
ps = (0.d0, 0.d0)
if (inverse_mode) then
IF (inverse_mode) THEN
CALL ZGEMM( 'C', 'N', nbnd, nbnd_occ (ikk), npw_k(ikk), (1.d0,0.d0), &
sevc, npwx, dvpsi, npwx, (0.d0,0.d0), ps, nbnd )
else
ELSE
CALL ZGEMM( 'C', 'N', nbnd, nbnd_occ (ikk), npw_k(ikk), (1.d0,0.d0), &
evq, npwx, dvpsi, npwx, (0.d0,0.d0), ps, nbnd )
endif
ENDIF
!
DO ibnd = 1, nbnd_occ (ikk)
wg1 = wgauss ((ef-et(ibnd,ikk)) / degauss, ngauss)
@ -128,8 +128,8 @@ contains
ps(jbnd,ibnd) = wwg * ps(jbnd,ibnd)
!
ENDDO
call DSCAL (2*npw_k(ikk), wg1, dvpsi(1,ibnd), 1)
END DO
CALL DSCAL (2*npw_k(ikk), wg1, dvpsi(1,ibnd), 1)
ENDDO
nbnd_eff=nbnd
ELSE
!
@ -138,102 +138,102 @@ contains
ps = (0.d0, 0.d0)
!OBM!!!
!ps = <evq|dvpsi>
! in the old version it was <sevc|dvpsi>
if (inverse_mode) then
! in the old version it was <sevc|dvpsi>
IF (inverse_mode) THEN
CALL ZGEMM( 'C', 'N', nbnd_occ(ikq), nbnd_occ (ikk), npw_k(ikk), &
(1.d0,0.d0), sevc, npwx, dvpsi, npwx, &
(0.d0,0.d0), ps, nbnd )
else
ELSE
CALL ZGEMM( 'C', 'N', nbnd_occ(ikq), nbnd_occ (ikk), npw_k(ikk), &
(1.d0,0.d0), evq, npwx, dvpsi, npwx, &
(0.d0,0.d0), ps, nbnd )
endif
ENDIF
nbnd_eff=nbnd_occ(ikk)
END IF
ENDIF
#ifdef __PARA
call mp_sum(ps(:,1:nbnd_eff),intra_pool_comm)
CALL mp_sum(ps(:,1:nbnd_eff),intra_pool_comm)
#endif
!!
!! |dvspi> = -(|dvpsi> - |sevc><evq|dvpsi>)
!!
!OBM!!! changed to |dvspi> = |dvpsi> - |sevc><evq|dvpsi>
if (lgauss) then
!OBM!!! changed to |dvspi> = |dvpsi> - |sevc><evq|dvpsi>
IF (lgauss) THEN
!
! metallic case
!
if (inverse_mode) then
IF (inverse_mode) THEN
CALL ZGEMM( 'N', 'N', npw_k(ikk), nbnd_occ(ikk), nbnd, &
(-1.d0,0.d0), evq, npwx, ps, nbnd, (1.0d0,0.d0), &
dvpsi, npwx )
else
ELSE
CALL ZGEMM( 'N', 'N', npw_k(ikk), nbnd_occ(ikk), nbnd, &
(-1.d0,0.d0), sevc, npwx, ps, nbnd, (1.0d0,0.d0), &
dvpsi, npwx )
endif
ENDIF
ELSE
!
! Insulators: note that nbnd_occ(ikk)=nbnd_occ(ikq) in an insulator
!
if (inverse_mode) then
IF (inverse_mode) THEN
CALL ZGEMM( 'N', 'N', npw_k(ikk), nbnd_occ(ikk), nbnd_occ(ikk), &
(-1.d0,0.d0), evq, npwx, ps, nbnd, (1.0d0,0.d0), &
dvpsi, npwx )
else
ELSE
CALL ZGEMM( 'N', 'N', npw_k(ikk), nbnd_occ(ikk), nbnd_occ(ikk), &
(-1.d0,0.d0), sevc, npwx, ps, nbnd, (1.0d0,0.d0), &
dvpsi, npwx )
endif
ENDIF
ENDIF
DEALLOCATE(ps)
end subroutine lr_ortho_k
END SUBROUTINE lr_ortho_k
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!Gamma point specific
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_ortho_gamma()
SUBROUTINE lr_ortho_gamma()
IMPLICIT NONE
COMPLEX(DP), ALLOCATABLE :: ps_c(:,:)
REAL(DP), ALLOCATABLE :: ps(:,:)
INTEGER :: ibnd, jbnd, nbnd_eff
REAL(DP) :: wg1, w0g, wgp, wwg, deltae, theta
REAL(DP), EXTERNAL :: w0gauss, wgauss
REAL(DP), EXTERNAL :: w0gauss, wgauss
ALLOCATE(ps(nbnd,nbnd))
ALLOCATE(ps_c(nbnd,nbnd))
!
if (lgauss) then
call errore ('lr_ortho', "degauss with gamma point algorithms",1)
IF (lgauss) THEN
CALL errore ('lr_ortho', "degauss with gamma point algorithms",1)
ELSE
!
! insulators
! ps = <evq|dvpsi>
! in old version it was ps = <S evc0|sv>
! in old version it was ps = <S evc0|sv>
ps = 0.d0
if (inverse_mode) then
IF (inverse_mode) THEN
CALL DGEMM( 'C', 'N', nbnd, nbnd ,2*npw_k(1), &
2.d0, sevc, 2*npwx, dvpsi, 2*npwx, &
0.d0, ps, nbnd )
0.d0, ps, nbnd )
!ps = 2*<sevc|dvpsi>
else
ELSE
CALL DGEMM( 'C', 'N', nbnd, nbnd ,2*npw_k(1), &
2.d0, evq, 2*npwx, dvpsi, 2*npwx, &
0.d0, ps, nbnd )
!ps = 2*<evq|dvpsi>
endif
ENDIF
nbnd_eff=nbnd
if (gstart == 2) then
if (inverse_mode) then
IF (gstart == 2) THEN
IF (inverse_mode) THEN
CALL DGER( nbnd, nbnd, -1.D0, sevc, 2*npwx, dvpsi, 2*npwx, ps, nbnd )
!PS = PS - sevc*dvpsi
else
ELSE
CALL DGER( nbnd, nbnd, -1.D0, evq, 2*npwx, dvpsi, 2*npwx, ps, nbnd )
!PS = PS - evc*dvpsi
endif
endif
END IF
ENDIF
ENDIF
ENDIF
#ifdef __PARA
call mp_sum(ps(:,:),intra_pool_comm)
CALL mp_sum(ps(:,:),intra_pool_comm)
#endif
! in the original dpsi was used as a storage for sevc, since in
! tddfpt we have it stored in memory as sevc0 this part is obsolote
@ -248,47 +248,47 @@ contains
!CALL s_psi (npwx, npwq, nbnd_eff, evq, dpsi)
ps_c = cmplx(ps, 0.d0, dp)
ps_c = cmplx(ps, 0.d0, dp)
!!
!! |dvspi> = -(|dvpsi> - S|evq><evq|dvpsi>)
!!
!OBM!!! changed to |dvspi> = |dvpsi> - |sevc><evq|dvpsi>
if (lgauss) then
!errore ?
!OBM!!! changed to |dvspi> = |dvpsi> - |sevc><evq|dvpsi>
IF (lgauss) THEN
!errore ?
ELSE
!
! Insulators: note that nbnd_occ(ikk)=nbnd_occ(ikq) in an insulator
!
if (inverse_mode) then
IF (inverse_mode) THEN
CALL ZGEMM( 'N', 'N', npw_k(1), nbnd, nbnd, &
(-1.d0,0.d0), evq, npwx, ps_c, nbnd, (1.0d0,0.d0), &
dvpsi, npwx )
!dvpsi=dvpsi-|evq><sevc|dvpsi>
else
ELSE
CALL ZGEMM( 'N', 'N', npw_k(1), nbnd, nbnd, &
(-1.d0,0.d0), sevc, npwx, ps_c, nbnd, (1.0d0,0.d0), &
dvpsi, npwx )
!dvpsi=dvpsi-|sevc><evq|dvpsi>
endif
ENDIF
ENDIF
DEALLOCATE(ps)
DEALLOCATE(ps_c)
end subroutine lr_ortho_gamma
END SUBROUTINE lr_ortho_gamma
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!noncolin specific
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine lr_ortho_noncolin()
SUBROUTINE lr_ortho_noncolin()
IMPLICIT NONE
COMPLEX(DP), ALLOCATABLE :: ps(:,:)
INTEGER :: ibnd, jbnd, nbnd_eff
REAL(DP) :: wg1, w0g, wgp, wwg, deltae, theta
REAL(DP), EXTERNAL :: w0gauss, wgauss
REAL(DP), EXTERNAL :: w0gauss, wgauss
ALLOCATE(ps(nbnd,nbnd))
!
if (lgauss) then
IF (lgauss) THEN
!
! metallic case
!
@ -320,7 +320,7 @@ contains
!
ENDDO
CALL DSCAL (2*npwx*npol, wg1, dvpsi(1,ibnd), 1)
END DO
ENDDO
nbnd_eff=nbnd
ELSE
!
@ -331,9 +331,9 @@ contains
(1.d0,0.d0), evq, npwx*npol, dvpsi, npwx*npol, &
(0.d0,0.d0), ps, nbnd )
nbnd_eff=nbnd_occ(ikk)
END IF
ENDIF
#ifdef __PARA
call mp_sum(ps(:,1:nbnd_eff),intra_pool_comm)
CALL mp_sum(ps(:,1:nbnd_eff),intra_pool_comm)
#endif
! in the original dpsi was used as a storage for sevc, since in
! tddfpt we have it stored in memory as sevc0 this part is obsolote
@ -350,7 +350,7 @@ contains
!! |dvspi> = -(|dvpsi> - S|evq><evq|dvpsi>)
!OBM!!! changed to |dvspi> = |dvpsi> - S|evq><evq|dvpsi> using this
!!
if (lgauss) then
IF (lgauss) THEN
!
! metallic case
!
@ -366,8 +366,8 @@ contains
dvpsi, npwx*npol )
ENDIF
DEALLOCATE(ps)
end subroutine lr_ortho_noncolin
END SUBROUTINE lr_ortho_noncolin
end subroutine lr_ortho
END SUBROUTINE lr_ortho
!-----------------------------------------------------------------------

64
TDDFPT/src/lr_read_d0psi.f90
View File

@ -1,67 +1,67 @@
!-----------------------------------------------------------------------
subroutine lr_read_d0psi()
SUBROUTINE lr_read_d0psi()
!---------------------------------------------------------------------
! ... reads in and stores the vectors necessary to
! ... reads in and stores the vectors necessary to
! ... restart the Lanczos recursion
!---------------------------------------------------------------------
! Modified by Osman Baris Malcioglu (2009)
!
#include "f_defs.h"
!
use klist, only : nks,degauss
use io_files, only : prefix, diropn, tmp_dir, wfc_dir
use lr_variables, only : d0psi, n_ipol,LR_polarization
use lr_variables, only : nwordd0psi, iund0psi
use wvfct, only : nbnd, npwx,et
USE klist, ONLY : nks,degauss
USE io_files, ONLY : prefix, diropn, tmp_dir, wfc_dir
USE lr_variables, ONLY : d0psi, n_ipol,LR_polarization
USE lr_variables, ONLY : nwordd0psi, iund0psi
USE wvfct, ONLY : nbnd, npwx,et
USE lr_variables, ONLY : lr_verbosity,restart
USE io_global, ONLY : stdout
!
implicit none
IMPLICIT NONE
!
! local variables
integer :: ip
character(len=6), external :: int_to_char
logical :: exst
character(len=256) :: tmp_dir_saved
INTEGER :: ip
CHARACTER(len=6), EXTERNAL :: int_to_char
LOGICAL :: exst
CHARACTER(len=256) :: tmp_dir_saved
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_read_d0psi>")')
endif
ENDIF
nwordd0psi = 2 * nbnd * npwx * nks
!
! This is a parallel read, done in wfc_dir
tmp_dir_saved = tmp_dir
IF ( wfc_dir /= 'undefined' ) tmp_dir = wfc_dir
do ip=1,n_ipol
DO ip=1,n_ipol
!
if (n_ipol==1) then
call diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
if (.not.exst .and. wfc_dir /= 'undefined') then
IF (n_ipol==1) THEN
CALL diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
IF (.not.exst .and. wfc_dir /= 'undefined') THEN
WRITE( stdout, '(/5x,"Attempting to read d0psi from outdir instead of wfcdir")' )
CLOSE( UNIT = iund0psi)
tmp_dir = tmp_dir_saved
call diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
if (.not.exst) call errore('lr_read_d0psi', TRIM( prefix )//'.d0psi.'//trim(int_to_char(LR_polarization))//' not found',1)
endif
endif
if (n_ipol==3) then
call diropn ( iund0psi, 'd0psi.'//trim(int_to_char(ip)), nwordd0psi, exst)
if (.not.exst .and. wfc_dir /= 'undefined') then
CALL diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
IF (.not.exst) CALL errore('lr_read_d0psi', trim( prefix )//'.d0psi.'//trim(int_to_char(LR_polarization))//' not found',1)
ENDIF
ENDIF
IF (n_ipol==3) THEN
CALL diropn ( iund0psi, 'd0psi.'//trim(int_to_char(ip)), nwordd0psi, exst)
IF (.not.exst .and. wfc_dir /= 'undefined') THEN
WRITE( stdout, '(/5x,"Attempting to read d0psi from outdir instead of wfcdir")' )
CLOSE( UNIT = iund0psi)
tmp_dir = tmp_dir_saved
call diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
if (.not.exst) call errore('lr_read_d0psi', TRIM( prefix )//'.d0psi.'//trim(int_to_char(ip))//' not found',1)
endif
endif
CALL diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
IF (.not.exst) CALL errore('lr_read_d0psi', trim( prefix )//'.d0psi.'//trim(int_to_char(ip))//' not found',1)
ENDIF
ENDIF
!
call davcio(d0psi(1,1,1,ip),nwordd0psi,iund0psi,1,-1)
CALL davcio(d0psi(1,1,1,ip),nwordd0psi,iund0psi,1,-1)
!
CLOSE( UNIT = iund0psi)
!
end do
ENDDO
! End of file i/o
tmp_dir = tmp_dir_saved
!
end subroutine lr_read_d0psi
END SUBROUTINE lr_read_d0psi
!-----------------------------------------------------------------------

486
TDDFPT/src/lr_read_wf.f90
View File

@ -1,5 +1,5 @@
!-----------------------------------------------------------------------
subroutine lr_read_wf()
SUBROUTINE lr_read_wf()
!---------------------------------------------------------------------
! ... reads in and stores the ground state wavefunctions
! ... for use in Lanczos linear response calculation
@ -8,23 +8,23 @@ subroutine lr_read_wf()
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use io_global, only : stdout
use klist, only : nks, xk
use cell_base, only : tpiba2
use gvect, only : ngm, g
use io_files, only : nwordwfc, iunwfc, prefix, diropn, tmp_dir, wfc_dir
use lr_variables, only : evc0, sevc0 ,revc0, evc0_virt, sevc0_virt, nbnd_total, &
USE io_global, ONLY : stdout
USE klist, ONLY : nks, xk
USE cell_base, ONLY : tpiba2
USE gvect, ONLY : ngm, g
USE io_files, ONLY : nwordwfc, iunwfc, prefix, diropn, tmp_dir, wfc_dir
USE lr_variables, ONLY : evc0, sevc0 ,revc0, evc0_virt, sevc0_virt, nbnd_total, &
becp1_virt,becp1_c_virt
use realus, only : igk_k,npw_k
use lr_variables, only : becp1, becp1_c,test_case_no,size_evc,project
use wvfct, only : npw, igk, nbnd, g2kin, npwx, ecutwfc
use control_flags, only : gamma_only
USE realus, ONLY : igk_k,npw_k
USE lr_variables, ONLY : becp1, becp1_c,test_case_no,size_evc,project
USE wvfct, ONLY : npw, igk, nbnd, g2kin, npwx, ecutwfc
USE control_flags, ONLY : gamma_only
!use wavefunctions_module,only : evc
use gvecs, only : nls, nlsm
use fft_base, only : dffts
use fft_interfaces, only : invfft
use uspp, only : vkb, nkb, okvan
use becmod, only : bec_type, becp, calbec
USE gvecs, ONLY : nls, nlsm
USE fft_base, ONLY : dffts
USE fft_interfaces, ONLY : invfft
USE uspp, ONLY : vkb, nkb, okvan
USE becmod, ONLY : bec_type, becp, calbec
!use lr_variables, only : real_space
!use real_beta, only : ccalbecr_gamma,s_psir,fft_orbital_gamma,bfft_orbital_gamma
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
@ -37,39 +37,39 @@ subroutine lr_read_wf()
!
implicit none
IMPLICIT NONE
!
!
!
! local variables
integer :: ik, ibnd, ig, itmp1,itmp2,itmp3
logical :: exst
character(len=256) :: filename, tmp_dir_saved
INTEGER :: ik, ibnd, ig, itmp1,itmp2,itmp3
LOGICAL :: exst
CHARACTER(len=256) :: filename, tmp_dir_saved
!OBM debug
real(kind=dp) :: obm_debug
complex(kind=dp),external :: lr_dot
COMPLEX(kind=dp),EXTERNAL :: lr_dot
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_read_wf>")')
endif
ENDIF
!
if (nbnd_total>nbnd .or. project) then
call virt_read()
else
call normal_read()
endif
IF (nbnd_total>nbnd .or. project) THEN
CALL virt_read()
ELSE
CALL normal_read()
ENDIF
!
!print *, "evc0",lr_dot(evc0(:,:,1),evc0(:,:,1))
!print *, "sevc0",lr_dot(sevc0(:,:,1),sevc0(:,:,1))
!print *, "<evc0|sevc0>",lr_dot(evc0(:,:,1),sevc0(:,:,1))
!print *, "<revc0>",lr_dot(revc0(:,:,1),revc0(:,:,1))
!print *, "becp1",lr_dot(becp1(:,:),becp1(:,:))
return
RETURN
!!!!
contains
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine normal_read()
SUBROUTINE normal_read()
!
!The usual way of reading wavefunctions
!
@ -84,37 +84,37 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
! This is a parallel read, done in wfc_dir
tmp_dir_saved = tmp_dir
IF ( wfc_dir /= 'undefined' ) tmp_dir = wfc_dir
call diropn ( iunwfc, 'wfc', nwordwfc, exst)
CALL diropn ( iunwfc, 'wfc', nwordwfc, exst)
!
if (.not.exst .and. wfc_dir == 'undefined') call errore('lr_read_wfc', TRIM( prefix )//'.wfc'//' not found',1)
IF (.not.exst .and. wfc_dir == 'undefined') CALL errore('lr_read_wfc', trim( prefix )//'.wfc'//' not found',1)
!
if (.not.exst .and. wfc_dir /= 'undefined') then
IF (.not.exst .and. wfc_dir /= 'undefined') THEN
WRITE( stdout, '(/5x,"Attempting to read wfc from outdir instead of wfcdir")' )
CLOSE( UNIT = iunwfc)
tmp_dir = tmp_dir_saved
call diropn ( iunwfc, 'wfc', nwordwfc, exst)
if (.not.exst) call errore('lr_read_wfc', TRIM( prefix )//'.wfc'//' not found',1)
endif
if (gamma_only) then
CALL diropn ( iunwfc, 'wfc', nwordwfc, exst)
IF (.not.exst) CALL errore('lr_read_wfc', trim( prefix )//'.wfc'//' not found',1)
ENDIF
IF (gamma_only) THEN
WRITE( stdout, '(/5x,"Gamma point algorithm")' )
else
call errore('lr_read_wfc', 'k-point algorithm is not tested yet',1)
ELSE
CALL errore('lr_read_wfc', 'k-point algorithm is not tested yet',1)
WRITE( stdout, '(/5x,"Generalised algorithm !warning")' )
endif
ENDIF
do ik=1,nks
DO ik=1,nks
!
if (.not. real_space_debug > 0 ) then !else done in init_realspace realus
IF (.not. real_space_debug > 0 ) THEN !else done in init_realspace realus
CALL gk_sort( xk(1,ik), ngm, g, ( ecutwfc / tpiba2 ), npw, igk, g2kin )
!
npw_k(ik) = npw
!
igk_k(:,ik) = igk(:)
endif
ENDIF
!
call davcio(evc0(:,:,ik),nwordwfc,iunwfc,ik,-1)
CALL davcio(evc0(:,:,ik),nwordwfc,iunwfc,ik,-1)
!
enddo
ENDDO
!
!
CLOSE( UNIT = iunwfc)
@ -126,119 +126,119 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
! vkb * evc0 and initialization of sevc0
!
!
if ( okvan ) then
IF ( okvan ) THEN
!
if ( gamma_only ) then
IF ( gamma_only ) THEN
!
! Following line is to be removed when real space implementation is complete
call init_us_2(npw,igk_k(:,1),xk(1,1),vkb)
CALL init_us_2(npw,igk_k(:,1),xk(1,1),vkb)
!
if (real_space_debug>0) then
IF (real_space_debug>0) THEN
!
!
!
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc0(:,:,1),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp1)
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc0(:,:,1),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp1)
becp%r(:,ibnd)=becp1(:,ibnd)
if (ibnd + 1 .le. nbnd) becp%r(:,ibnd+1)=becp1(:,ibnd+1)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(sevc0(:,:,1),ibnd,nbnd)
enddo
IF (ibnd + 1 <= nbnd) becp%r(:,ibnd+1)=becp1(:,ibnd+1)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(sevc0(:,:,1),ibnd,nbnd)
ENDDO
!rbecp=becp1
!print *,rbecp
!
if (test_case_no .eq. 1) then
write(stdout,'(/5x,"Test Case 1, dumping Real space calculated rbecp and sevc0",1x)')
IF (test_case_no == 1) THEN
WRITE(stdout,'(/5x,"Test Case 1, dumping Real space calculated rbecp and sevc0",1x)')
filename=trim(prefix) // "-rbecp-rs.dump"
OPEN(UNIT=47,FILE=filename,STATUS='NEW',ACCESS = 'SEQUENTIAL')
write(unit=47,FMT='("#RBECP SIZE :",i6," number of beta fs",i6," bands",i6)') size(becp%r)&
WRITE(unit=47,FMT='("#RBECP SIZE :",i6," number of beta fs",i6," bands",i6)') size(becp%r)&
,size(becp%r,1),size(becp%r,2)
do itmp2=1, SIZE(becp%r,2)
write(unit=47,FMT='("#Band no",i3)') itmp2
do itmp1=1, SIZE(becp%r,1)
write(unit=47,FMT=*) becp%r(itmp1,itmp2)
enddo
enddo
close(47)
DO itmp2=1, size(becp%r,2)
WRITE(unit=47,FMT='("#Band no",i3)') itmp2
DO itmp1=1, size(becp%r,1)
WRITE(unit=47,FMT=*) becp%r(itmp1,itmp2)
ENDDO
ENDDO
CLOSE(47)
filename=trim(prefix) // "-sevc0-rs.dump"
OPEN(UNIT=48,FILE=filename,STATUS='NEW',ACCESS = 'SEQUENTIAL')
write(unit=48,FMT='("#SEVC0 SIZE :",i6," NPW ",i6," BANDS ",i6," DIM3",i6)') size(sevc0), &
WRITE(unit=48,FMT='("#SEVC0 SIZE :",i6," NPW ",i6," BANDS ",i6," DIM3",i6)') size(sevc0), &
size(sevc0,1), size(sevc0,2), size(sevc0,3)
do itmp2=1, SIZE(sevc0,2)
write(unit=48,FMT='("#Band no",i3)') itmp2
do itmp1=1, SIZE(sevc0,1)
write(unit=48,FMT='(i6,2x,e21.15, 2x, e21.15,2x)') itmp1, DBLE(sevc0(itmp1,itmp2,1)), AIMAG(sevc0(itmp1,itmp2,1))
enddo
enddo
DO itmp2=1, size(sevc0,2)
WRITE(unit=48,FMT='("#Band no",i3)') itmp2
DO itmp1=1, size(sevc0,1)
WRITE(unit=48,FMT='(i6,2x,e21.15, 2x, e21.15,2x)') itmp1, dble(sevc0(itmp1,itmp2,1)), aimag(sevc0(itmp1,itmp2,1))
ENDDO
ENDDO
close(48)
endif
CLOSE(48)
ENDIF
!print *, becp1-rbecp
!
! makedo part until spsi is in place - obsolote
! call s_psi(npwx, npw_k(1), nbnd, evc0(:,:,1), sevc0(:,:,1))
else
ELSE
!
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,evc0,npwx,becp1,nkb)
call calbec(npw_k(1),vkb,evc0(:,:,1),becp1)
CALL calbec(npw_k(1),vkb,evc0(:,:,1),becp1)
!
becp%r=becp1
!
call s_psi(npwx, npw_k(1), nbnd, evc0(:,:,1), sevc0(:,:,1))
CALL s_psi(npwx, npw_k(1), nbnd, evc0(:,:,1), sevc0(:,:,1))
! Test case
if (test_case_no .eq. 1) then
write(stdout,'(/5x,"Test Case 1, dumping Fourier space calculated rbecp and sevc0",1x)')
IF (test_case_no == 1) THEN
WRITE(stdout,'(/5x,"Test Case 1, dumping Fourier space calculated rbecp and sevc0",1x)')
filename=trim(prefix) // "-rbecp.dump"
OPEN(UNIT=47,FILE=filename,STATUS='NEW',ACCESS = 'SEQUENTIAL')
write(unit=47,FMT='("#RBECP SIZE :",i6," number of beta fs",i6," bands",i6)') size(becp%r)&
WRITE(unit=47,FMT='("#RBECP SIZE :",i6," number of beta fs",i6," bands",i6)') size(becp%r)&
,size(becp%r,1),size(becp%r,2)
do itmp2=1, SIZE(becp%r,2)
write(unit=47,FMT='("#Band no",i3)') itmp2
do itmp1=1, SIZE(becp%r,1)
write(unit=47,FMT=*) becp%r(itmp1,itmp2)
enddo
enddo
close(47)
DO itmp2=1, size(becp%r,2)
WRITE(unit=47,FMT='("#Band no",i3)') itmp2
DO itmp1=1, size(becp%r,1)
WRITE(unit=47,FMT=*) becp%r(itmp1,itmp2)
ENDDO
ENDDO
CLOSE(47)
filename=trim(prefix) // "-sevc0.dump"
OPEN(UNIT=48,FILE=filename,STATUS='NEW',ACCESS = 'SEQUENTIAL')
write(unit=48,FMT='("#SEVC0 SIZE :",i6," NPW ",i6," BANDS ",i6," DIM3",i6)') size(sevc0), &
WRITE(unit=48,FMT='("#SEVC0 SIZE :",i6," NPW ",i6," BANDS ",i6," DIM3",i6)') size(sevc0), &
size(sevc0,1), size(sevc0,2), size(sevc0,3)
do itmp2=1, SIZE(sevc0,2)
write(unit=48,FMT='("#Band no",i3)') itmp2
do itmp1=1, SIZE(sevc0,1)
write(unit=48,FMT='(i6,2x,e21.15, 2x, e21.15,2x)') itmp1, DBLE(sevc0(itmp1,itmp2,1)), AIMAG(sevc0(itmp1,itmp2,1))
enddo
enddo
close(48)
endif
DO itmp2=1, size(sevc0,2)
WRITE(unit=48,FMT='("#Band no",i3)') itmp2
DO itmp1=1, size(sevc0,1)
WRITE(unit=48,FMT='(i6,2x,e21.15, 2x, e21.15,2x)') itmp1, dble(sevc0(itmp1,itmp2,1)), aimag(sevc0(itmp1,itmp2,1))
ENDDO
ENDDO
CLOSE(48)
ENDIF
!
endif
else
ENDIF
ELSE
!
! K point generalized stuff starts here
do ik=1,nks
DO ik=1,nks
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!
!call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp1_c(:,:,ik),vkb,evc0(:,:,ik))
call calbec(npw_k(ik),vkb,evc0(:,:,ik),becp1_c(:,:,ik))
CALL calbec(npw_k(ik),vkb,evc0(:,:,ik),becp1_c(:,:,ik))
!
becp%k=becp1_c(:,:,ik)
!
call s_psi (npwx, npw_k(ik), nbnd, evc0(:,:,ik), sevc0(:,:,ik))
CALL s_psi (npwx, npw_k(ik), nbnd, evc0(:,:,ik), sevc0(:,:,ik))
!
end do
ENDDO
!
end if
ENDIF
!
else
ELSE
!
sevc0=evc0
!
end if
ENDIF
!
!
! Inverse fourier transform of evc0
@ -246,13 +246,13 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
!
revc0=(0.0d0,0.0d0)
!
if ( gamma_only ) then
IF ( gamma_only ) THEN
!
do ibnd=1,nbnd,2
DO ibnd=1,nbnd,2
!
if (ibnd<nbnd) then
IF (ibnd<nbnd) THEN
!
do ig=1,npw_k(1)
DO ig=1,npw_k(1)
!
revc0(nls(igk_k(ig,1)),ibnd,1)=evc0(ig,ibnd,1)+&
(0.0d0,1.0d0)*evc0(ig,ibnd+1,1)
@ -260,97 +260,97 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
revc0(nlsm(igk_k(ig,1)),ibnd,1)=conjg(evc0(ig,ibnd,1)-&
(0.0d0,1.0d0)*evc0(ig,ibnd+1,1))
!
end do
ENDDO
!
else
ELSE
!
do ig=1,npw_k(1)
DO ig=1,npw_k(1)
!
revc0(nls(igk_k(ig,1)),ibnd,1)=evc0(ig,ibnd,1)
!
revc0(nlsm(igk_k(ig,1)),ibnd,1)=conjg(evc0(ig,ibnd,1))
!
enddo
ENDDO
!
endif
ENDIF
!
CALL invfft ('Wave', revc0(:,ibnd,1), dffts)
!
end do
ENDDO
!
else
ELSE
!
do ik=1,nks
DO ik=1,nks
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
do ig=1,npw_k(ik)
DO ig=1,npw_k(ik)
!
revc0(nls(igk_k(ig,ik)),ibnd,ik)=evc0(ig,ibnd,ik)
!
enddo
ENDDO
!
CALL invfft ('Wave', revc0(:,ibnd,ik), dffts)
!
end do
ENDDO
!
end do
ENDDO
!
end if
ENDIF
!
!print * , "evc0 ",evc0(1:3,1,1)
!
if (lr_verbosity >10) then
call check_all_bands_gamma(evc0(:,:,1),sevc0(:,:,1),nbnd,nbnd)
write(stdout,'("evc0")')
do ibnd=1,nbnd
call check_vector_gamma(evc0(:,ibnd,1))
enddo
call check_density_gamma(revc0(:,:,1),nbnd)
endif
IF (lr_verbosity >10) THEN
CALL check_all_bands_gamma(evc0(:,:,1),sevc0(:,:,1),nbnd,nbnd)
WRITE(stdout,'("evc0")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc0(:,ibnd,1))
ENDDO
CALL check_density_gamma(revc0(:,:,1),nbnd)
ENDIF
!
!OBM!!! debug---
!CALL lr_normalise( evc0(:,:,1), obm_debug)
!print *, "norm of evc0 ",obm_debug
!OBM!!! debug---
! OBM - Last minute check for real space implementation,
IF ( real_space_debug > 0 .and. .NOT. gamma_only ) &
IF ( real_space_debug > 0 .and. .not. gamma_only ) &
CALL errore( ' iosys ', ' Linear response calculation ' // &
& 'real space algorithms with k-points not implemented', 1 )
!
end subroutine normal_read
END SUBROUTINE normal_read
!-----------------------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine virt_read()
SUBROUTINE virt_read()
!
!The modifications to read also the virtual orbitals
!
USE control_ph, ONLY : nbnd_occ
use grid_dimensions, only : nrxx
USE grid_dimensions, ONLY : nrxx
USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
check_vector_gamma
IMPLICIT NONE
complex(kind=dp), allocatable :: evc_all(:,:,:)
complex(kind=dp), allocatable :: sevc_all(:,:,:)
real(kind=dp), allocatable :: becp1_all(:,:)
complex(kind=dp), allocatable :: becp1_c_all(:,:,:)
complex(kind=dp), allocatable :: revc_all(:,:,:)
COMPLEX(kind=dp), ALLOCATABLE :: evc_all(:,:,:)
COMPLEX(kind=dp), ALLOCATABLE :: sevc_all(:,:,:)
real(kind=dp), ALLOCATABLE :: becp1_all(:,:)
COMPLEX(kind=dp), ALLOCATABLE :: becp1_c_all(:,:,:)
COMPLEX(kind=dp), ALLOCATABLE :: revc_all(:,:,:)
!First pretend everything is normal
nbnd=nbnd_total
!
allocate(revc_all(nrxx,nbnd,nks))
allocate(evc_all(npwx,nbnd,nks))
allocate(sevc_all(npwx,nbnd,nks))
if (nkb > 0) then
if(gamma_only) then
allocate(becp1_all(nkb,nbnd))
ALLOCATE(revc_all(nrxx,nbnd,nks))
ALLOCATE(evc_all(npwx,nbnd,nks))
ALLOCATE(sevc_all(npwx,nbnd,nks))
IF (nkb > 0) THEN
IF(gamma_only) THEN
ALLOCATE(becp1_all(nkb,nbnd))
becp1_all(:,:)=0.0d0
else
allocate(becp1_c_all(nkb,nbnd,nks))
ELSE
ALLOCATE(becp1_c_all(nkb,nbnd,nks))
becp1_c_all(:,:,:)=(0.0d0,0.0d0)
endif
endif
ENDIF
ENDIF
nwordwfc = 2 * nbnd * npwx
@ -360,40 +360,40 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
! This is a parallel read, done in wfc_dir
tmp_dir_saved = tmp_dir
IF ( wfc_dir /= 'undefined' ) tmp_dir = wfc_dir
call diropn ( iunwfc, 'wfc', nwordwfc, exst)
CALL diropn ( iunwfc, 'wfc', nwordwfc, exst)
!
if (.not.exst .and. wfc_dir == 'undefined') call errore('lr_read_wfc', TRIM( prefix )//'.wfc'//' not found',1)
IF (.not.exst .and. wfc_dir == 'undefined') CALL errore('lr_read_wfc', trim( prefix )//'.wfc'//' not found',1)
!
if (.not.exst .and. wfc_dir /= 'undefined') then
IF (.not.exst .and. wfc_dir /= 'undefined') THEN
WRITE( stdout, '(/5x,"Attempting to read from outdir instead of wfcdir")' )
CLOSE( UNIT = iunwfc)
tmp_dir = tmp_dir_saved
call diropn ( iunwfc, 'wfc', nwordwfc, exst)
if (.not.exst) call errore('lr_read_wfc', TRIM( prefix )//'.wfc'//' not found',1)
endif
CALL diropn ( iunwfc, 'wfc', nwordwfc, exst)
IF (.not.exst) CALL errore('lr_read_wfc', trim( prefix )//'.wfc'//' not found',1)
ENDIF
!
if (gamma_only) then
IF (gamma_only) THEN
WRITE( stdout, '(/5x,"Gamma point algorithm")' )
else
call errore('lr_read_wfc', 'k-point algorithm is not tested yet',1)
ELSE
CALL errore('lr_read_wfc', 'k-point algorithm is not tested yet',1)
WRITE( stdout, '(/5x,"Generalised algorithm !warning")' )
endif
ENDIF
do ik=1,nks
DO ik=1,nks
!
if (.not. real_space_debug > 0 ) then !else done in init_realspace realus
IF (.not. real_space_debug > 0 ) THEN !else done in init_realspace realus
CALL gk_sort( xk(1,ik), ngm, g, ( ecutwfc / tpiba2 ), npw, igk, g2kin )
!
npw_k(ik) = npw
!
igk_k(:,ik) = igk(:)
endif
ENDIF
!
! Read in the ground state wavefunctions
! This is a parallel read, done in wfc_dir
call davcio(evc_all(:,:,ik),nwordwfc,iunwfc,ik,-1)
CALL davcio(evc_all(:,:,ik),nwordwfc,iunwfc,ik,-1)
!
enddo
ENDDO
!
!
CLOSE( UNIT = iunwfc)
@ -405,56 +405,56 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
! vkb * evc_all and initialization of sevc_all
!
!
if ( okvan ) then
IF ( okvan ) THEN
!
if ( gamma_only ) then
IF ( gamma_only ) THEN
!
! Following line is to be removed when real space implementation is complete
call init_us_2(npw,igk_k(:,1),xk(1,1),vkb)
CALL init_us_2(npw,igk_k(:,1),xk(1,1),vkb)
!
if (real_space_debug>0) then
IF (real_space_debug>0) THEN
!
!
!
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc_all(:,:,1),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp1_all)
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc_all(:,:,1),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp1_all)
becp%r(:,ibnd)=becp1_all(:,ibnd)
if (ibnd + 1 .le. nbnd) becp%r(:,ibnd+1)=becp1_all(:,ibnd+1)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(sevc_all(:,:,1),ibnd,nbnd)
enddo
else
IF (ibnd + 1 <= nbnd) becp%r(:,ibnd+1)=becp1_all(:,ibnd+1)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(sevc_all(:,:,1),ibnd,nbnd)
ENDDO
ELSE
!
call calbec(npw_k(1),vkb,evc_all(:,:,1),becp1_all)
CALL calbec(npw_k(1),vkb,evc_all(:,:,1),becp1_all)
!
becp%r=becp1_all
!
call s_psi(npwx, npw_k(1), nbnd, evc_all(:,:,1), sevc_all(:,:,1))
CALL s_psi(npwx, npw_k(1), nbnd, evc_all(:,:,1), sevc_all(:,:,1))
!
endif
else
ENDIF
ELSE
!
! K point generalized stuff starts here
do ik=1,nks
DO ik=1,nks
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!
call calbec(npw_k(ik),vkb,evc_all(:,:,ik),becp1_c_all(:,:,ik),nbnd)
CALL calbec(npw_k(ik),vkb,evc_all(:,:,ik),becp1_c_all(:,:,ik),nbnd)
!
becp%k=becp1_c_all(:,:,ik)
!
call s_psi (npwx, npw_k(ik), nbnd, evc_all(:,:,ik), sevc_all(:,:,ik))
CALL s_psi (npwx, npw_k(ik), nbnd, evc_all(:,:,ik), sevc_all(:,:,ik))
!
end do
ENDDO
!
end if
ENDIF
!
else
ELSE
!
sevc_all=evc_all
!
end if
ENDIF
!
!
! Inverse fourier transform of evc_all
@ -462,13 +462,13 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
!
revc_all=(0.0d0,0.0d0)
!
if ( gamma_only ) then
IF ( gamma_only ) THEN
!
do ibnd=1,nbnd,2
DO ibnd=1,nbnd,2
!
if (ibnd<nbnd) then
IF (ibnd<nbnd) THEN
!
do ig=1,npw_k(1)
DO ig=1,npw_k(1)
!
revc_all(nls(igk_k(ig,1)),ibnd,1)=evc_all(ig,ibnd,1)+&
(0.0d0,1.0d0)*evc_all(ig,ibnd+1,1)
@ -476,43 +476,43 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
revc_all(nlsm(igk_k(ig,1)),ibnd,1)=conjg(evc_all(ig,ibnd,1)-&
(0.0d0,1.0d0)*evc_all(ig,ibnd+1,1))
!
end do
ENDDO
!
else
ELSE
!
do ig=1,npw_k(1)
DO ig=1,npw_k(1)
!
revc_all(nls(igk_k(ig,1)),ibnd,1)=evc_all(ig,ibnd,1)
!
revc_all(nlsm(igk_k(ig,1)),ibnd,1)=conjg(evc_all(ig,ibnd,1))
!
enddo
ENDDO
!
endif
ENDIF
!
CALL invfft ('Wave', revc_all(:,ibnd,1), dffts)
!
end do
ENDDO
!
else
ELSE
!
do ik=1,nks
DO ik=1,nks
!
do ibnd=1,nbnd
DO ibnd=1,nbnd
!
do ig=1,npw_k(ik)
DO ig=1,npw_k(ik)
!
revc_all(nls(igk_k(ig,ik)),ibnd,ik)=evc_all(ig,ibnd,ik)
!
enddo
ENDDO
!
CALL invfft ('Wave', revc_all(:,ibnd,ik), dffts)
!
end do
ENDDO
!
end do
ENDDO
!
end if
ENDIF
!
!now everything goes into right place
!
@ -524,52 +524,52 @@ USE lr_variables, ONLY: check_all_bands_gamma, check_density_gamma,&
sevc0(:,:,:)=sevc_all(:,1:nbnd,:)
revc0=(0.0d0,0.0d0)
revc0(:,:,:)=revc_all(:,1:nbnd,:)
if (nkb>0) then
if (gamma_only) then
IF (nkb>0) THEN
IF (gamma_only) THEN
becp1(:,:)=becp1_all(:,1:nbnd)
becp%r=0.0d0
becp%r=becp1
else
ELSE
becp1_c(:,:,:)=becp1_c_all(:,1:nbnd,:)
becp%k=(0.0d0,0.0d0)
becp%k=becp1_c(:,:,1)
endif
endif
if (project) then
ENDIF
ENDIF
IF (project) THEN
evc0_virt(:,:,:)=evc_all(:,nbnd+1:nbnd_total,:)
!sevc0_virt(:,:,:)=sevc_all(:,nbnd+1:nbnd_total,:)
if (nkb>0) then
if (gamma_only) then
IF (nkb>0) THEN
IF (gamma_only) THEN
becp1_virt(:,:)=becp1_all(:,nbnd+1:nbnd_total)
else
ELSE
becp1_c_virt(:,:,:)=becp1_c_all(:,nbnd+1:nbnd_total,:)
endif
endif
endif
if (lr_verbosity >10) then
call check_all_bands_gamma(evc_all(:,:,1),sevc_all(:,:,1),nbnd_total,nbnd)
call check_density_gamma(revc_all(:,:,1),nbnd)
write(stdout,'("evc0")')
do ibnd=1,nbnd
call check_vector_gamma(evc0(:,ibnd,1))
enddo
endif
if (nkb>0) then
if (gamma_only) then
deallocate(becp1_all)
else
deallocate(becp1_c_all)
endif
endif
deallocate(evc_all)
deallocate(sevc_all)
deallocate(revc_all)
ENDIF
ENDIF
ENDIF
IF (lr_verbosity >10) THEN
CALL check_all_bands_gamma(evc_all(:,:,1),sevc_all(:,:,1),nbnd_total,nbnd)
CALL check_density_gamma(revc_all(:,:,1),nbnd)
WRITE(stdout,'("evc0")')
DO ibnd=1,nbnd
CALL check_vector_gamma(evc0(:,ibnd,1))
ENDDO
ENDIF
IF (nkb>0) THEN
IF (gamma_only) THEN
DEALLOCATE(becp1_all)
ELSE
DEALLOCATE(becp1_c_all)
ENDIF
ENDIF
DEALLOCATE(evc_all)
DEALLOCATE(sevc_all)
DEALLOCATE(revc_all)
! OBM - Last minute check for real space implementation,
IF ( real_space_debug > 0 .and. .NOT. gamma_only ) &
IF ( real_space_debug > 0 .and. .not. gamma_only ) &
CALL errore( ' iosys ', ' Linear response calculation ' // &
& 'real space algorithms with k-points not implemented', 1 )
!
end subroutine virt_read
END SUBROUTINE virt_read
!-----------------------------------------------------------------------
end subroutine lr_read_wf
END SUBROUTINE lr_read_wf

180
TDDFPT/src/lr_readin.f90
View File

@ -6,7 +6,7 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine lr_readin
SUBROUTINE lr_readin
!-----------------------------------------------------------------------
!
! This routine reads the control variables from standard input (unit 5).
@ -16,27 +16,27 @@ subroutine lr_readin
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
use lr_variables
USE kinds, only : DP
use io_files, only : tmp_dir, prefix,trimcheck,wfc_dir
use lsda_mod, only : current_spin, nspin
use control_flags, only : twfcollect
USE lr_variables
USE kinds, ONLY : DP
USE io_files, ONLY : tmp_dir, prefix,trimcheck,wfc_dir
USE lsda_mod, ONLY : current_spin, nspin
USE control_flags, ONLY : twfcollect
USE scf, ONLY : vltot, v, vrs, vnew, &
& destroy_scf_type
USE grid_dimensions, ONLY : nrxx
USE gvecs, ONLY : doublegrid
use wvfct, only : nbnd, et, wg
use lsda_mod, only : isk
use ener, only : ef
USE wvfct, ONLY : nbnd, et, wg
USE lsda_mod, ONLY : isk
USE ener, ONLY : ef
USE io_global, ONLY : ionode, ionode_id
use klist, only : nks, wk, nelec
use fixed_occ, only : tfixed_occ
use input_parameters, only : degauss, nosym,wfcdir,outdir
use ktetra, only : ltetra
USE klist, ONLY : nks, wk, nelec
USE fixed_occ, ONLY : tfixed_occ
USE input_parameters, ONLY : degauss, nosym,wfcdir,outdir
USE ktetra, ONLY : ltetra
USE realus, ONLY : real_space, real_space_debug, &
init_realspace_vars, qpointlist, &
betapointlist,read_rs_status,newd_r
USE funct, only : dft_is_meta
USE funct, ONLY : dft_is_meta
USE io_global, ONLY : stdout
USE control_flags, ONLY : tqr
USE iotk_module
@ -45,26 +45,26 @@ subroutine lr_readin
USE mp_global, ONLY : my_pool_id, intra_image_comm, intra_pool_comm
USE io_global, ONLY : ionode, ionode_id
USE DFUNCT, ONLY : newd
USE vlocal, only : strf
USE vlocal, ONLY : strf
IMPLICIT NONE
!
character(len=256) :: beta_gamma_z_prefix
CHARACTER(len=256) :: beta_gamma_z_prefix
! fine control of beta_gamma_z file
CHARACTER(len=80) :: disk_io
! Specify the amount of I/O activities
integer :: ios, iunout,ierr,ipol
logical :: auto_rs
INTEGER :: ios, iunout,ierr,ipol
LOGICAL :: auto_rs
!
namelist / lr_input / restart, restart_step ,lr_verbosity, prefix, outdir, test_case_no, wfcdir,disk_io
namelist / lr_control / itermax, ipol, ltammd, real_space, real_space_debug, charge_response, tqr, auto_rs, no_hxc,n_ipol,project
namelist / lr_post / omeg, beta_gamma_z_prefix, w_T_npol, plot_type, epsil,itermax_int
NAMELIST / lr_input / restart, restart_step ,lr_verbosity, prefix, outdir, test_case_no, wfcdir,disk_io
NAMELIST / lr_control / itermax, ipol, ltammd, real_space, real_space_debug, charge_response, tqr, auto_rs, no_hxc,n_ipol,project
NAMELIST / lr_post / omeg, beta_gamma_z_prefix, w_T_npol, plot_type, epsil,itermax_int
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_readin>")')
endif
ENDIF
auto_rs = .true.
#ifdef __PARA
if (ionode) then
IF (ionode) THEN
#endif
!
! Set default values for variables in namelist
@ -97,36 +97,36 @@ subroutine lr_readin
!
! Reading the namelist lr_input
!
call input_from_file( )
CALL input_from_file( )
!
READ (5, lr_input, err = 200, iostat = ios)
200 CALL errore ('lr_readin', 'reading lr_input namelist', abs (ios) )
!
read (5, lr_input, err = 200, iostat = ios)
200 call errore ('lr_readin', 'reading lr_input namelist', abs (ios) )
!
!
! Reading the namelist lr_control
!
read (5, lr_control, err = 201, iostat = ios)
201 call errore ('lr_readin', 'reading lr_control namelist', abs (ios) )
READ (5, lr_control, err = 201, iostat = ios)
201 CALL errore ('lr_readin', 'reading lr_control namelist', abs (ios) )
!
!
! Reading the namelist lr_post
!
if (charge_response == 1) then
read (5, lr_post, err = 202, iostat = ios)
202 call errore ('lr_readin', 'reading lr_post namelist', abs (ios) )
bgz_suffix = TRIM ( "-stage2.beta_gamma_z." )
write(stdout,'(/5x,"Prefix of current run is appended by -stage2")')
IF ( beta_gamma_z_prefix == 'undefined' ) then
IF (charge_response == 1) THEN
READ (5, lr_post, err = 202, iostat = ios)
202 CALL errore ('lr_readin', 'reading lr_post namelist', abs (ios) )
bgz_suffix = trim ( "-stage2.beta_gamma_z." )
WRITE(stdout,'(/5x,"Prefix of current run is appended by -stage2")')
IF ( beta_gamma_z_prefix == 'undefined' ) THEN
beta_gamma_z_prefix=trim(prefix)
endif
else
bgz_suffix = TRIM ( ".beta_gamma_z." )
endif
ENDIF
ELSE
bgz_suffix = trim ( ".beta_gamma_z." )
ENDIF
!
! The status of the real space flags should be read manually
!
!
! Do not mess with already present wfc structure
twfcollect = .FALSE.
twfcollect = .false.
!
outdir = trimcheck(outdir)
tmp_dir = outdir
@ -142,30 +142,30 @@ subroutine lr_readin
!
!Charge response mode 1 is the "do Lanczos chains twice, conserve memory" scheme
!
if (charge_response == 1 .and. omeg == 0.D0) &
call errore ('lr_readin', 'omeg must be defined for charge response mode 1', 1 )
if ( project .and. charge_response /= 1) &
call errore ('lr_readin', 'projection is possible only in charge response mode 1', 1 )
IF (charge_response == 1 .and. omeg == 0.D0) &
CALL errore ('lr_readin', 'omeg must be defined for charge response mode 1', 1 )
IF ( project .and. charge_response /= 1) &
CALL errore ('lr_readin', 'projection is possible only in charge response mode 1', 1 )
w_T_prefix = TRIM( tmp_dir ) // TRIM( beta_gamma_z_prefix ) // ".beta_gamma_z."
w_T_prefix = trim( tmp_dir ) // trim( beta_gamma_z_prefix ) // ".beta_gamma_z."
!
ierr = 0
!
if ( ipol==4 ) then
!
IF ( ipol==4 ) THEN
!
n_ipol = 3
LR_polarization=1
LR_polarization=1
!
else
ELSE
!
LR_polarization=ipol
!
end if
if (itermax_int < itermax) itermax_int=itermax
ENDIF
IF (itermax_int < itermax) itermax_int=itermax
!
! Limited disk_io support: currently only one setting is supported
!
!
SELECT CASE( trim( disk_io ) )
CASE ( 'reduced' )
!
@ -178,31 +178,31 @@ SELECT CASE( trim( disk_io ) )
END SELECT
#ifdef __PARA
end if
call bcast_lr_input
call mp_bcast(auto_rs, ionode_id)
ENDIF
CALL bcast_lr_input
CALL mp_bcast(auto_rs, ionode_id)
#endif
!
!print *, "post broad"
!print *, "rs_status"
outdir = TRIM( tmp_dir ) // TRIM( prefix ) // '.save'
if (auto_rs) call read_rs_status( outdir, ierr )
if (real_space) real_space_debug=99
if (real_space_debug > 0) real_space=.true.
If (lr_verbosity > 1) THEN
outdir = trim( tmp_dir ) // trim( prefix ) // '.save'
IF (auto_rs) CALL read_rs_status( outdir, ierr )
IF (real_space) real_space_debug=99
IF (real_space_debug > 0) real_space=.true.
IF (lr_verbosity > 1) THEN
WRITE(stdout,'(5x,"Status of real space flags: TQR=", L5 ," REAL_SPACE=", L5)') tqr, real_space
endif
ENDIF
!print *, "rs_status-ended"
! Now PWSCF XML file will be read, and various initialisations will be done
!
!print *, "newd"
!print *, "newd"
!
!print *, "read_file"
!call mp_barrier()
call read_file()
CALL read_file()
DEALLOCATE( strf )
CALL destroy_scf_type(vnew)
DEALLOCATE( strf )
CALL destroy_scf_type(vnew)
!
!
@ -212,46 +212,46 @@ END SELECT
current_spin=1
!
call init_us_1 ( )
CALL init_us_1 ( )
!
if (tqr) then
call newd_r()
else
call newd() !OBM: this is for the ground charge density
endif
IF (tqr) THEN
CALL newd_r()
ELSE
CALL newd() !OBM: this is for the ground charge density
ENDIF
!
if (dft_is_meta()) &
IF (dft_is_meta()) &
CALL errore( ' iosys ', ' Meta DFT ' // &
& 'not implemented yet', 1 )
if ( real_space_debug > 0 ) then
write(stdout,'(/5x,"Real space implementation V.1 D190908",1x)')
IF ( real_space_debug > 0 ) THEN
WRITE(stdout,'(/5x,"Real space implementation V.1 D190908",1x)')
! !OBM - correct parellism issues
call init_realspace_vars()
call betapointlist()
write(stdout,'(5X,"Real space initialisation completed")')
endif
CALL init_realspace_vars()
CALL betapointlist()
WRITE(stdout,'(5X,"Real space initialisation completed")')
ENDIF
!
!print *, "set_vrs"
call set_vrs ( vrs, vltot, v%of_r, 0, 0, nrxx, nspin, doublegrid )
CALL set_vrs ( vrs, vltot, v%of_r, 0, 0, nrxx, nspin, doublegrid )
DEALLOCATE( vltot )
CALL destroy_scf_type(v)
DEALLOCATE( vltot )
CALL destroy_scf_type(v)
call iweights( nks, wk, nbnd, nelec, et, ef, wg, 0, isk)
CALL iweights( nks, wk, nbnd, nelec, et, ef, wg, 0, isk)
!
!
if ( charge_response == 2 ) call lr_set_boxes_density()
IF ( charge_response == 2 ) CALL lr_set_boxes_density()
!
! Checking
! Checking
!
IF ( (ltetra .OR. tfixed_occ .OR. (degauss /= 0.D0)) ) &
IF ( (ltetra .or. tfixed_occ .or. (degauss /= 0.D0)) ) &
CALL errore( ' iosys ', ' Linear response calculation ' // &
& 'not implemented for non-insulating systems', 1 )
IF ( .NOT. nosym ) &
IF ( .not. nosym ) &
CALL errore( ' iosys ', ' Linear response calculation ' // &
& 'not implemented with symmetry', 1 )
!
return
end subroutine lr_readin
RETURN
END SUBROUTINE lr_readin

270
TDDFPT/src/lr_restart.f90
View File

@ -1,5 +1,5 @@
!-----------------------------------------------------------------------
subroutine lr_restart(iter_restart,rflag)
SUBROUTINE lr_restart(iter_restart,rflag)
!---------------------------------------------------------------------
! ... restart the Lanczos recursion
!---------------------------------------------------------------------
@ -7,76 +7,76 @@ subroutine lr_restart(iter_restart,rflag)
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use io_global, only : stdout, ionode_id
use control_flags, only : gamma_only
use klist, only : nks, xk
use cell_base, only : tpiba2
use gvect, only : g
use io_files, only : tmp_dir, prefix, diropn, wfc_dir
use lr_variables, only : itermax,evc1, evc1_new, sevc1_new, rho_1_tot , rho_1_tot_im,&
USE io_global, ONLY : stdout, ionode_id
USE control_flags, ONLY : gamma_only
USE klist, ONLY : nks, xk
USE cell_base, ONLY : tpiba2
USE gvect, ONLY : g
USE io_files, ONLY : tmp_dir, prefix, diropn, wfc_dir
USE lr_variables, ONLY : itermax,evc1, evc1_new, sevc1_new, rho_1_tot , rho_1_tot_im,&
restart, nwordrestart, iunrestart,project,nbnd_total,F,&
bgz_suffix
use charg_resp, only : resonance_condition
use wvfct, only : npw, igk, nbnd, g2kin, npwx
use lr_variables, only : beta_store, gamma_store, zeta_store, norm0!,real_space
use becmod, only : bec_type, becp, calbec
use uspp, only : vkb, nkb, okvan
USE charg_resp, ONLY : resonance_condition
USE wvfct, ONLY : npw, igk, nbnd, g2kin, npwx
USE lr_variables, ONLY : beta_store, gamma_store, zeta_store, norm0!,real_space
USE becmod, ONLY : bec_type, becp, calbec
USE uspp, ONLY : vkb, nkb, okvan
USE io_global, ONLY : ionode
use mp, only : mp_bcast
USE mp, ONLY : mp_bcast
!use real_beta, only : ccalbecr_gamma,s_psir,fft_orbital_gamma,bfft_orbital_gamma
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
bfft_orbital_gamma, calbec_rs_gamma, add_vuspsir_gamma, &
v_loc_psir, s_psir_gamma,igk_k,npw_k, &
real_space_debug
use grid_dimensions, only : nrxx
real_space_debug
USE grid_dimensions, ONLY : nrxx
USE lr_variables, ONLY : lr_verbosity, charge_response, LR_polarization, n_ipol
USE noncollin_module, ONLY : nspin_mag
!
implicit none
IMPLICIT NONE
!
character(len=6), external :: int_to_char
CHARACTER(len=6), EXTERNAL :: int_to_char
!
!integer, intent(in) :: pol
integer, intent(out) :: iter_restart
logical, intent(out) :: rflag
INTEGER, INTENT(out) :: iter_restart
LOGICAL, INTENT(out) :: rflag
!
! local variables
!
integer :: i,ibnd,ibnd_occ,ibnd_virt,temp
integer :: ik, ig, ip
logical :: exst
character(len=256) :: tempfile, filename,tmp_dir_saved
integer :: pol_index
INTEGER :: i,ibnd,ibnd_occ,ibnd_virt,temp
INTEGER :: ik, ig, ip
LOGICAL :: exst
CHARACTER(len=256) :: tempfile, filename,tmp_dir_saved
INTEGER :: pol_index
!
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_restart>")')
endif
ENDIF
pol_index=1
if ( n_ipol /= 1 ) pol_index=LR_polarization
IF ( n_ipol /= 1 ) pol_index=LR_polarization
if (.not.restart) return
IF (.not.restart) RETURN
!
rflag = .false.
!
! Restarting kintic-energy and ultrasoft
!
if (gamma_only) then
IF (gamma_only) THEN
!
do ig=1,npwx
DO ig=1,npwx
!
g2kin(ig)=((xk(1,1)+g(1,igk_k(ig,1)))**2 &
+(xk(2,1)+g(2,igk_k(ig,1)))**2 &
+(xk(3,1)+g(3,igk_k(ig,1)))**2)*tpiba2
!
enddo
ENDDO
!
call init_us_2(npw,igk,xk(1,1),vkb)
CALL init_us_2(npw,igk,xk(1,1),vkb)
!
end if
ENDIF
!
! Reading Lanczos coefficients
!
@ -84,15 +84,15 @@ subroutine lr_restart(iter_restart,rflag)
filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(LR_polarization))
tempfile = trim(tmp_dir) // trim(filename)
!
inquire (file = tempfile, exist = exst)
INQUIRE (file = tempfile, exist = exst)
!
if (.not.exst) then
IF (.not.exst) THEN
!
WRITE( stdout,*) "WARNING: " // trim(filename) // " does not exist"
rflag = .true.
return
RETURN
!
end if
ENDIF
!
!
!Ionode only reads
@ -100,74 +100,74 @@ subroutine lr_restart(iter_restart,rflag)
! Note Ionode file io is done in tmp_dir
!
#ifdef __PARA
if (ionode) then
IF (ionode) THEN
#endif
!
! Read and broadcast beta gamma zeta
! Read and broadcast beta gamma zeta
!
open (158, file = tempfile, form = 'formatted', status = 'old')
OPEN (158, file = tempfile, form = 'formatted', status = 'old')
!
read(158,*,end=301,err=303) iter_restart
READ(158,*,end=301,err=303) iter_restart
!
if ( iter_restart .ge. itermax ) iter_restart = itermax
IF ( iter_restart >= itermax ) iter_restart = itermax
!
read(158,*,end=301,err=303) norm0(pol_index)
READ(158,*,end=301,err=303) norm0(pol_index)
!
do i=1,iter_restart
DO i=1,iter_restart
!
read(158,*,end=301,err=303) beta_store(pol_index,i)
read(158,*,end=301,err=303) gamma_store(pol_index,i)
read(158,*,end=301,err=303) zeta_store (pol_index,:,i)
READ(158,*,end=301,err=303) beta_store(pol_index,i)
READ(158,*,end=301,err=303) gamma_store(pol_index,i)
READ(158,*,end=301,err=303) zeta_store (pol_index,:,i)
!
end do
ENDDO
!
close(158)
CLOSE(158)
#ifdef __PARA
endif
call mp_bcast (iter_restart, ionode_id)
call mp_bcast (norm0(pol_index), ionode_id)
call mp_bcast (beta_store(pol_index,:), ionode_id)
call mp_bcast (gamma_store(pol_index,:), ionode_id)
call mp_bcast (zeta_store(pol_index,:,:), ionode_id)
ENDIF
CALL mp_bcast (iter_restart, ionode_id)
CALL mp_bcast (norm0(pol_index), ionode_id)
CALL mp_bcast (beta_store(pol_index,:), ionode_id)
CALL mp_bcast (gamma_store(pol_index,:), ionode_id)
CALL mp_bcast (zeta_store(pol_index,:,:), ionode_id)
#endif
!
!
! Read projection
!
if (project) then
IF (project) THEN
#ifdef __PARA
if (ionode) then
IF (ionode) THEN
#endif
filename = trim(prefix) // ".projection." // trim(int_to_char(LR_polarization))
tempfile = trim(tmp_dir) // trim(filename)
!
!
open (158, file = tempfile, form = 'formatted', status = 'unknown')
OPEN (158, file = tempfile, form = 'formatted', status = 'unknown')
!
read(158,*,end=301,err=303) temp
READ(158,*,end=301,err=303) temp
!
if (temp /= iter_restart) call errore ('lr_restart', 'Iteration mismatch reading projections', 1 )
IF (temp /= iter_restart) CALL errore ('lr_restart', 'Iteration mismatch reading projections', 1 )
!
read(158,*,end=301,err=303) temp !number of filled bands
READ(158,*,end=301,err=303) temp !number of filled bands
!
if (temp /= nbnd) call errore ('lr_restart', 'NBND mismatch reading projections', 1 )
IF (temp /= nbnd) CALL errore ('lr_restart', 'NBND mismatch reading projections', 1 )
!
read(158,*,end=301,err=303) temp !total number of bands
READ(158,*,end=301,err=303) temp !total number of bands
!
if (temp /= nbnd_total) call errore ('lr_restart', 'Total number of bands mismatch reading projections', 1 )
IF (temp /= nbnd_total) CALL errore ('lr_restart', 'Total number of bands mismatch reading projections', 1 )
!
do ibnd_occ=1,nbnd
do ibnd_virt=1,(nbnd_total-nbnd)
read(158,*,end=301,err=303) F(ibnd_occ,ibnd_virt,pol_index)
enddo
enddo
DO ibnd_occ=1,nbnd
DO ibnd_virt=1,(nbnd_total-nbnd)
READ(158,*,end=301,err=303) F(ibnd_occ,ibnd_virt,pol_index)
ENDDO
ENDDO
!
close(158)
CLOSE(158)
#ifdef __PARA
end if
call mp_bcast (F, ionode_id)
ENDIF
CALL mp_bcast (F, ionode_id)
#endif
endif
ENDIF
!
iter_restart = iter_restart + 1
@ -181,92 +181,92 @@ subroutine lr_restart(iter_restart,rflag)
!
nwordrestart = 2 * nbnd * npwx * nks
!
call diropn ( iunrestart, 'restart_lanczos.'//trim(int_to_char(LR_polarization)), nwordrestart, exst)
CALL diropn ( iunrestart, 'restart_lanczos.'//trim(int_to_char(LR_polarization)), nwordrestart, exst)
!
call davcio(evc1(:,:,:,1),nwordrestart,iunrestart,1,-1)
call davcio(evc1(:,:,:,2),nwordrestart,iunrestart,2,-1)
call davcio(evc1_new(:,:,:,1),nwordrestart,iunrestart,3,-1)
call davcio(evc1_new(:,:,:,2),nwordrestart,iunrestart,4,-1)
CALL davcio(evc1(:,:,:,1),nwordrestart,iunrestart,1,-1)
CALL davcio(evc1(:,:,:,2),nwordrestart,iunrestart,2,-1)
CALL davcio(evc1_new(:,:,:,1),nwordrestart,iunrestart,3,-1)
CALL davcio(evc1_new(:,:,:,2),nwordrestart,iunrestart,4,-1)
!
close( unit = iunrestart)
if (charge_response == 1 ) then
if (resonance_condition) then
call diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx, exst)
call davcio(rho_1_tot_im(:,:),2*nrxx*nspin_mag,iunrestart,1,-1)
close( unit = iunrestart)
else
call diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx, exst)
call davcio(rho_1_tot(:,:),2*nrxx*nspin_mag,iunrestart,1,-1)
close( unit = iunrestart)
endif
endif
CLOSE( unit = iunrestart)
IF (charge_response == 1 ) THEN
IF (resonance_condition) THEN
CALL diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx, exst)
CALL davcio(rho_1_tot_im(:,:),2*nrxx*nspin_mag,iunrestart,1,-1)
CLOSE( unit = iunrestart)
ELSE
CALL diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx, exst)
CALL davcio(rho_1_tot(:,:),2*nrxx*nspin_mag,iunrestart,1,-1)
CLOSE( unit = iunrestart)
ENDIF
ENDIF
!
! End of all file i/o for restart
!
!
! Reinitializing sevc1_new vector
!
if (gamma_only) then
IF (gamma_only) THEN
!
if ( nkb > 0 .and. okvan ) then
if (real_space_debug>6) then
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc1_new(:,:,1,1),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp%r)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(sevc1_new(:,:,1,1),ibnd,nbnd)
enddo
else
call calbec(npw_k(1),vkb,evc1_new(:,:,1,1),becp)
IF ( nkb > 0 .and. okvan ) THEN
IF (real_space_debug>6) THEN
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc1_new(:,:,1,1),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp%r)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(sevc1_new(:,:,1,1),ibnd,nbnd)
ENDDO
ELSE
CALL calbec(npw_k(1),vkb,evc1_new(:,:,1,1),becp)
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,evc1_new(1,1,1,1),npwx,rbecp,nkb)
call s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,1),sevc1_new(:,:,1,1))
endif
else
CALL s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,1),sevc1_new(:,:,1,1))
ENDIF
ELSE
!nkb = 0 not real space
!
call s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,1),sevc1_new(:,:,1,1))
CALL s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,1),sevc1_new(:,:,1,1))
!
!
endif
ENDIF
!
if ( nkb > 0 .and. okvan ) then
if (real_space_debug>6) then
do ibnd=1,nbnd,2
call fft_orbital_gamma(evc1_new(:,:,1,2),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp%r)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(sevc1_new(:,:,1,2),ibnd,nbnd)
enddo
else
call calbec(npw_k(1),vkb,evc1_new(:,:,1,2),becp%r)
IF ( nkb > 0 .and. okvan ) THEN
IF (real_space_debug>6) THEN
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(evc1_new(:,:,1,2),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp%r)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(sevc1_new(:,:,1,2),ibnd,nbnd)
ENDDO
ELSE
CALL calbec(npw_k(1),vkb,evc1_new(:,:,1,2),becp%r)
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,evc1_new(1,1,1,2),npwx,rbecp,nkb)
call s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,2),sevc1_new(:,:,1,2))
endif
endif
CALL s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,2),sevc1_new(:,:,1,2))
ENDIF
ENDIF
!call s_psi(npwx,npw_k(1),nbnd,evc1_new(:,:,1,2),sevc1_new(:,:,1,2))
!
else
ELSE
!
do ik=1,nks
DO ik=1,nks
!
if ( nkb > 0 .and. okvan ) then
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
IF ( nkb > 0 .and. okvan ) THEN
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp,vkb,evc1_new(1,1,ik,1))
call calbec(npw_k(ik), vkb, evc1_new(:,:,ik,1), becp)
endif
call s_psi(npwx,npw_k(ik),nbnd,evc1_new(:,:,ik,1),sevc1_new(:,:,ik,1))
CALL calbec(npw_k(ik), vkb, evc1_new(:,:,ik,1), becp)
ENDIF
CALL s_psi(npwx,npw_k(ik),nbnd,evc1_new(:,:,ik,1),sevc1_new(:,:,ik,1))
!
if (nkb > 0) call calbec(npw_k(ik), vkb, evc1_new(:,:,ik,2), becp)
IF (nkb > 0) CALL calbec(npw_k(ik), vkb, evc1_new(:,:,ik,2), becp)
!call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp,vkb,evc1_new(1,1,ik,2))
call s_psi(npwx,npw_k(ik),nbnd,evc1_new(:,:,ik,2),sevc1_new(:,:,ik,2))
CALL s_psi(npwx,npw_k(ik),nbnd,evc1_new(:,:,ik,2),sevc1_new(:,:,ik,2))
!
enddo
ENDDO
!
end if
ENDIF
!
!
return
301 call errore ('restart', 'A File is corrupted, file ended unexpectedly', 1 )
303 call errore ('restart', 'A File is corrupted, error in reading data', 1)
end subroutine lr_restart
RETURN
301 CALL errore ('restart', 'A File is corrupted, file ended unexpectedly', 1 )
303 CALL errore ('restart', 'A File is corrupted, error in reading data', 1)
END SUBROUTINE lr_restart
!-----------------------------------------------------------------------

22
TDDFPT/src/lr_set_boxes_density.f90
View File

@ -1,7 +1,7 @@
!-----------------------------------------------------------------------
!OBM
! 150608 pfft replaced by fft_base :: dfftp
SUBROUTINE lr_set_boxes_density()
SUBROUTINE lr_set_boxes_density()
!---------------------------------------------------------------------
! ... set boxes for the calculation of density response
!---------------------------------------------------------------------
@ -9,12 +9,12 @@ SUBROUTINE lr_set_boxes_density()
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use io_global, only : stdout
use kinds, only : dp
use lr_variables, only : cube_save
USE io_global, ONLY : stdout
USE kinds, ONLY : dp
USE lr_variables, ONLY : cube_save
!use pfft, only : npp
use fft_base, only : dfftp
use mp_global, only : me_pool
USE fft_base, ONLY : dfftp
USE mp_global, ONLY : me_pool
USE lr_variables, ONLY : lr_verbosity
!
IMPLICIT NONE
@ -22,9 +22,9 @@ SUBROUTINE lr_set_boxes_density()
INTEGER :: index0, index, ir
INTEGER :: i, j, k, p, nr
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_set_boxes_density>")')
endif
ENDIF
CALL start_clock( 'lr_set_boxes' )
!
ALLOCATE( cube_save( dfftp%nnr, 3 ) )
@ -36,7 +36,7 @@ SUBROUTINE lr_set_boxes_density()
!
DO i = 1, me_pool
index0 = index0 + dfftp%nr1x*dfftp%nr2x*dfftp%npp(i)
END DO
ENDDO
!
#endif
!
@ -51,13 +51,13 @@ SUBROUTINE lr_set_boxes_density()
index = index - dfftp%nr1x*j
i = index
!
IF ( i.GE.dfftp%nr1 .OR. j.GE.dfftp%nr2 .OR. k.GE.dfftp%nr3 ) CYCLE
IF ( i>=dfftp%nr1 .or. j>=dfftp%nr2 .or. k>=dfftp%nr3 ) CYCLE
!
cube_save(ir,1) = i
cube_save(ir,2) = j
cube_save(ir,3) = k
!
END DO
ENDDO
!
CALL stop_clock( 'lr_set_boxes' )
!

102
TDDFPT/src/lr_setup_dgc.f90
View File

@ -6,7 +6,7 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine lr_setup_dgc
SUBROUTINE lr_setup_dgc
!-----------------------------------------------------------------------
! Allocate and setup all variable needed in the gradient correction case
!
@ -16,33 +16,33 @@ subroutine lr_setup_dgc
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
use pwcom, only : nspin, ngm, g, nl, e2
use grid_dimensions,only : nrxx
USE kinds, only : DP
use lr_variables, only : lr_verbosity
use funct, only : dft_is_gradient, gcxc, gcx_spin, gcc_spin, &
USE pwcom, ONLY : nspin, ngm, g, nl, e2
USE grid_dimensions,ONLY : nrxx
USE kinds, ONLY : DP
USE lr_variables, ONLY : lr_verbosity
USE funct, ONLY : dft_is_gradient, gcxc, gcx_spin, gcc_spin, &
dgcxc, dgcxc_spin
!obm -strange-
use nlcc_ph, only : nlcc_any
use gc_ph, only : grho,dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s
use scf, only : rho,rho_core,rhog_core
!obm -strange-
USE nlcc_ph, ONLY : nlcc_any
USE gc_ph, ONLY : grho,dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s
USE scf, ONLY : rho,rho_core,rhog_core
USE io_global, ONLY : stdout
implicit none
integer :: k, is
IMPLICIT NONE
INTEGER :: k, is
real(DP) :: grho2 (2), rh, zeta1, grh2, fac, sx, sc, &
v1x, v2x, v1c, v2c, vrrx, vsrx, vssx, vrrc, vsrc, vssc, v1xup, &
v1xdw, v2xup, v2xdw, v1cup, v1cdw, vrrxup, vrrxdw, vrsxup, vrsxdw, &
vssxup, vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vrzcup, vrzcdw
real (DP), parameter :: epsr = 1.0d-6, epsg = 1.0d-10
If (lr_verbosity > 5) THEN
real (DP), PARAMETER :: epsr = 1.0d-6, epsg = 1.0d-10
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_setup_dgc>")')
endif
if ( .not. dft_is_gradient() ) return
allocate (dvxc_rr( nrxx , nspin , nspin))
allocate (dvxc_sr( nrxx , nspin , nspin))
allocate (dvxc_ss( nrxx , nspin , nspin))
allocate (dvxc_s ( nrxx , nspin , nspin))
allocate (grho ( 3 , nrxx , nspin))
ENDIF
IF ( .not. dft_is_gradient() ) RETURN
ALLOCATE (dvxc_rr( nrxx , nspin , nspin))
ALLOCATE (dvxc_sr( nrxx , nspin , nspin))
ALLOCATE (dvxc_ss( nrxx , nspin , nspin))
ALLOCATE (dvxc_s ( nrxx , nspin , nspin))
ALLOCATE (grho ( 3 , nrxx , nspin))
dvxc_rr(:,:,:) = 0.d0
dvxc_sr(:,:,:) = 0.d0
@ -52,29 +52,29 @@ subroutine lr_setup_dgc
!
! add rho_core
!
fac = 1.d0 / DBLE (nspin)
if (nlcc_any) then
do is = 1, nspin
fac = 1.d0 / dble (nspin)
IF (nlcc_any) THEN
DO is = 1, nspin
rho%of_r (:,is) = fac * rho_core(:) + rho%of_r (:,is)
rho%of_g (:,is) = fac * rhog_core(:) + rho%of_g (:,is)
enddo
endif
do is = 1, nspin
call gradrho (nrxx, rho%of_g (1, is), ngm, g, nl, grho (1, 1, is) )
enddo
do k = 1, nrxx
ENDDO
ENDIF
DO is = 1, nspin
CALL gradrho (nrxx, rho%of_g (1, is), ngm, g, nl, grho (1, 1, is) )
ENDDO
DO k = 1, nrxx
grho2 (1) = grho (1, k, 1) **2 + grho (2, k, 1) **2 + grho (3, k, 1) **2
if (nspin == 1) then
if (abs (rho%of_r (k, 1) ) > epsr .and. grho2 (1) > epsg) then
call gcxc (rho%of_r (k, nspin), grho2(1), sx, sc, v1x, v2x, v1c, v2c)
call dgcxc (rho%of_r (k, nspin), grho2(1), vrrx, vsrx, vssx, vrrc, &
IF (nspin == 1) THEN
IF (abs (rho%of_r (k, 1) ) > epsr .and. grho2 (1) > epsg) THEN
CALL gcxc (rho%of_r (k, nspin), grho2(1), sx, sc, v1x, v2x, v1c, v2c)
CALL dgcxc (rho%of_r (k, nspin), grho2(1), vrrx, vsrx, vssx, vrrc, &
vsrc, vssc)
dvxc_rr (k, 1, 1) = e2 * (vrrx + vrrc)
dvxc_sr (k, 1, 1) = e2 * (vsrx + vsrc)
dvxc_ss (k, 1, 1) = e2 * (vssx + vssc)
dvxc_s (k, 1, 1) = e2 * (v2x + v2c)
endif
else
ENDIF
ELSE
grho2 (2) = grho (1, k, 2) **2 + grho (2, k, 2) **2 + grho (3, &
k, 2) **2
rh = rho%of_r (k, 1) + rho%of_r (k, 2)
@ -82,15 +82,15 @@ subroutine lr_setup_dgc
grh2 = (grho (1, k, 1) + grho (1, k, 2) ) **2 + (grho (2, k, 1) &
+ grho (2, k, 2) ) **2 + (grho (3, k, 1) + grho (3, k, 2) ) ** 2
call gcx_spin (rho%of_r (k, 1), rho%of_r (k, 2), grho2 (1), grho2 (2), &
CALL gcx_spin (rho%of_r (k, 1), rho%of_r (k, 2), grho2 (1), grho2 (2), &
sx, v1xup, v1xdw, v2xup, v2xdw)
call dgcxc_spin (rho%of_r (k, 1), rho%of_r (k, 2), grho (1, k, 1), &
CALL dgcxc_spin (rho%of_r (k, 1), rho%of_r (k, 2), grho (1, k, 1), &
grho (1, k, 2), vrrxup, vrrxdw, vrsxup, vrsxdw, vssxup, vssxdw, &
vrrcup, vrrcdw, vrscup, vrscdw, vssc, vrzcup, vrzcdw)
if (rh > epsr) then
IF (rh > epsr) THEN
zeta1 = (rho%of_r(k, 1) - rho%of_r(k, 2) ) / rh
call gcc_spin (rh, zeta1, grh2, sc, v1cup, v1cdw, v2c)
CALL gcc_spin (rh, zeta1, grh2, sc, v1cup, v1cdw, v2c)
dvxc_rr (k, 1, 1) = e2 * (vrrxup + vrrcup + vrzcup * &
(1.d0 - zeta1) / rh)
dvxc_rr (k, 1, 2) = e2 * (vrrcup - vrzcup * (1.d0 + zeta1) / rh)
@ -101,7 +101,7 @@ subroutine lr_setup_dgc
dvxc_s (k, 1, 2) = e2 * v2c
dvxc_s (k, 2, 1) = e2 * v2c
dvxc_s (k, 2, 2) = e2 * (v2xdw + v2c)
else
ELSE
dvxc_rr (k, 1, 1) = 0.d0
dvxc_rr (k, 1, 2) = 0.d0
dvxc_rr (k, 2, 1) = 0.d0
@ -110,7 +110,7 @@ subroutine lr_setup_dgc
dvxc_s (k, 1, 2) = 0.d0
dvxc_s (k, 2, 1) = 0.d0
dvxc_s (k, 2, 2) = 0.d0
endif
ENDIF
dvxc_sr (k, 1, 1) = e2 * (vrsxup + vrscup)
dvxc_sr (k, 1, 2) = e2 * vrscup
dvxc_sr (k, 2, 1) = e2 * vrscdw
@ -119,16 +119,16 @@ subroutine lr_setup_dgc
dvxc_ss (k, 1, 2) = e2 * vssc
dvxc_ss (k, 2, 1) = e2 * vssc
dvxc_ss (k, 2, 2) = e2 * (vssxdw + vssc)
endif
enddo
if (nlcc_any) then
do is = 1, nspin
ENDIF
ENDDO
IF (nlcc_any) THEN
DO is = 1, nspin
rho%of_r(:,is) = rho%of_r(:,is) - fac * rho_core(:)
rho%of_g(:,is) = rho%of_g(:,is) - fac * rhog_core(:)
enddo
endif
ENDDO
ENDIF
DEALLOCATE(rhog_core)
DEALLOCATE(rhog_core)
return
end subroutine lr_setup_dgc
RETURN
END SUBROUTINE lr_setup_dgc

790
TDDFPT/src/lr_sm1_psi.f90
View File

File diff suppressed because it is too large Load Diff

122
TDDFPT/src/lr_solve_e.f90
View File

@ -6,7 +6,7 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-------------------------------------------------------------------------
subroutine lr_solve_e
SUBROUTINE lr_solve_e
!-----------------------------------------------------------------------
!
! bwalker: This routine is a driver for the solution of the linear
@ -22,45 +22,45 @@ subroutine lr_solve_e
!
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
use kinds, only : dp
use gvect, only : gstart
use io_global, only : stdout
use io_files, only : diropn, tmp_dir, wfc_dir
use klist, only : nks, xk, degauss
use lr_variables, only : nwordd0psi, iund0psi,LR_polarization, test_case_no
use lr_variables, only : n_ipol, evc0, d0psi, evc1, lr_verbosity
use realus, only : igk_k,npw_k
use lsda_mod, only : lsda, isk, current_spin
use uspp, only : vkb
use wvfct, only : igk, nbnd, npwx, npw, et
use control_flags, only : gamma_only
use wavefunctions_module, only : evc
USE kinds, ONLY : dp
USE gvect, ONLY : gstart
USE io_global, ONLY : stdout
USE io_files, ONLY : diropn, tmp_dir, wfc_dir
USE klist, ONLY : nks, xk, degauss
USE lr_variables, ONLY : nwordd0psi, iund0psi,LR_polarization, test_case_no
USE lr_variables, ONLY : n_ipol, evc0, d0psi, evc1, lr_verbosity
USE realus, ONLY : igk_k,npw_k
USE lsda_mod, ONLY : lsda, isk, current_spin
USE uspp, ONLY : vkb
USE wvfct, ONLY : igk, nbnd, npwx, npw, et
USE control_flags, ONLY : gamma_only
USE wavefunctions_module, ONLY : evc
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
USE mp, ONLY : mp_max,mp_min
USE realus, ONLY : real_space, real_space_debug!, dvpsir_e
USE control_ph, ONLY : alpha_pv
!
implicit none
IMPLICIT NONE
!
! counter on bands
! counter on k points
! counter on spins
! counter on polarizations
integer :: ibnd, ik, is, ip
INTEGER :: ibnd, ik, is, ip
!
!OBM!! this has been moved to lr_init_nfo
!! variables for calculating lr_alpha_pv
!real(kind=dp) :: emin, emax
!
character(len=6), external :: int_to_char
logical :: exst
CHARACTER(len=6), EXTERNAL :: int_to_char
LOGICAL :: exst
real (kind=dp) :: anorm
character(len=256) :: tmp_dir_saved
CHARACTER(len=256) :: tmp_dir_saved
!
If (lr_verbosity > 5) WRITE(stdout,'("<lr_solve_e>")')
IF (lr_verbosity > 5) WRITE(stdout,'("<lr_solve_e>")')
!if ( lsda ) call errore ( 'lr_solve_e' , ' LSDA not implemented' , 1)
!
call start_clock ('lr_solve_e')
CALL start_clock ('lr_solve_e')
!OBM!!! This has been moved to lr_init_nfo
! !!
@ -94,8 +94,8 @@ subroutine lr_solve_e
! !
!endif
!!
if( lr_verbosity > 1 ) &
write(stdout,'(5X,"lr_solve_e: alpha_pv=",1X,e12.5)') alpha_pv
IF( lr_verbosity > 1 ) &
WRITE(stdout,'(5X,"lr_solve_e: alpha_pv=",1X,e12.5)') alpha_pv
!
!
!if ( real_space_debug > 8 .and. gamma_only) then
@ -113,60 +113,60 @@ subroutine lr_solve_e
! !
! call dvpsir_e(ik,ipol,d0psi(:,:,1,1),lr_alpha_pv)
! !
! end if
! end if
!else
! print *, "Vkb electric field operator"
do ik=1,nks
DO ik=1,nks
!
if ( lsda ) current_spin = isk(ik)
IF ( lsda ) current_spin = isk(ik)
!
evc(:,:)=evc0(:,:,ik)
!
npw=npw_k(ik)
igk(:)=igk_k(:,ik)
!
call init_us_2(npw,igk,xk(1,ik),vkb)
CALL init_us_2(npw,igk,xk(1,ik),vkb)
!
! Computes/reads P_c^+ x psi_kpoint into d0psi array
!
if ( n_ipol==3 ) then
IF ( n_ipol==3 ) THEN
!
do ip=1,3
DO ip=1,3
!
call lr_dvpsi_e(ik,ip,d0psi(:,:,ik,ip))
CALL lr_dvpsi_e(ik,ip,d0psi(:,:,ik,ip))
!
end do
ENDDO
!
else if ( n_ipol==1 ) then
ELSEIF ( n_ipol==1 ) THEN
!
call lr_dvpsi_e(ik,LR_polarization,d0psi(:,:,ik,1))
CALL lr_dvpsi_e(ik,LR_polarization,d0psi(:,:,ik,1))
!
end if
ENDIF
!
!print *, "lr_solve_e, after lr_dvpsi_e"
!CALL lr_normalise( d0psi(:,:,1,1), anorm)
enddo
ENDDO
!endif
!
if (gstart == 2 .and. gamma_only) d0psi(1,:,:,:) = cmplx(dble(d0psi(1,:,:,:)),0.0d0,dp)
IF (gstart == 2 .and. gamma_only) d0psi(1,:,:,:) = cmplx(dble(d0psi(1,:,:,:)),0.0d0,dp)
!OBM!!! debug
if (test_case_no .eq. 2) then
print *,"dumping d0psi"
IF (test_case_no == 2) THEN
PRINT *,"dumping d0psi"
OPEN(UNIT=47,FILE="d0psi.dump",STATUS='NEW',ACCESS = 'SEQUENTIAL')
write(unit=47,FMT=*) "Kpoint --- band --- plane wave --- value for pol1 --- value for pol2 --- value for pol3"
do ik=1,nks
do ibnd=1,nbnd
do ip=1, npw
write(unit=47,FMT='(I3," ",2(I7," "), 3("(",E14.5," ",E14.5,"i)"))') ik, &
ibnd, ip, d0psi(ip,ibnd,ik,1), d0psi(ip,ibnd,ik,3), d0psi(ip,ibnd,ik,3)
enddo
enddo
enddo
close(47)
print *, "dump complete"
endif
WRITE(unit=47,FMT=*) "Kpoint --- band --- plane wave --- value for pol1 --- value for pol2 --- value for pol3"
DO ik=1,nks
DO ibnd=1,nbnd
DO ip=1, npw
WRITE(unit=47,FMT='(I3," ",2(I7," "), 3("(",E14.5," ",E14.5,"i)"))') ik, &
ibnd, ip, d0psi(ip,ibnd,ik,1), d0psi(ip,ibnd,ik,3), d0psi(ip,ibnd,ik,3)
ENDDO
ENDDO
ENDDO
CLOSE(47)
PRINT *, "dump complete"
ENDIF
!OBM!!! end of debug
!print *, "lr_solve_e before dump"
!CALL lr_normalise( d0psi(:,:,1,1), anorm)
!
@ -174,31 +174,31 @@ endif
!
nwordd0psi = 2 * nbnd * npwx * nks
!
! Reading of files:
! Reading of files:
! This is a parallel read, done in wfc_dir
tmp_dir_saved = tmp_dir
IF ( wfc_dir /= 'undefined' ) tmp_dir = wfc_dir
do ip = 1, n_ipol
DO ip = 1, n_ipol
!
if (n_ipol==1) call diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
if (n_ipol==3) call diropn ( iund0psi, 'd0psi.'//trim(int_to_char(ip)), nwordd0psi, exst)
IF (n_ipol==1) CALL diropn ( iund0psi, 'd0psi.'//trim(int_to_char(LR_polarization)), nwordd0psi, exst)
IF (n_ipol==3) CALL diropn ( iund0psi, 'd0psi.'//trim(int_to_char(ip)), nwordd0psi, exst)
!
call davcio(d0psi(1,1,1,ip),nwordd0psi,iund0psi,1,1)
CALL davcio(d0psi(1,1,1,ip),nwordd0psi,iund0psi,1,1)
!
CLOSE( UNIT = iund0psi)
!
end do
ENDDO
! End of file i/o
tmp_dir = tmp_dir_saved
!
! end writing
!
call stop_clock ('lr_solve_e')
CALL stop_clock ('lr_solve_e')
!
write(stdout,'(5X,"lr_wfcinit_spectrum: finished lr_solve_e")')
WRITE(stdout,'(5X,"lr_wfcinit_spectrum: finished lr_solve_e")')
!
return
RETURN
!
end subroutine lr_solve_e
END SUBROUTINE lr_solve_e
!-------------------------------------------------------------------------

232
TDDFPT/src/lr_variables.f90
View File

@ -6,33 +6,33 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
module lr_variables
MODULE lr_variables
!--------------------------------------------------------------------------
! ... sets the dimensions of the variables required in the
! ... Lanczos/linear response calculation
!--------------------------------------------------------------------------
!
! Modified by Osman Baris Malcioglu (2009)
use kinds, only : dp
use control_flags, only : gamma_only
USE kinds, ONLY : dp
USE control_flags, ONLY : gamma_only
!
implicit none
IMPLICIT NONE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Parameters
! Parameters
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
INTEGER, PARAMETER:: nbrx=14 ! max number of beta functions
!
integer :: iund0psi = 20
integer :: iunrestart = 20
integer :: nwordd0psi
integer :: nwordrestart
INTEGER :: iund0psi = 20
INTEGER :: iunrestart = 20
INTEGER :: nwordd0psi
INTEGER :: nwordrestart
!
integer :: n_ipol
INTEGER :: n_ipol
!
!
integer :: size_evc
INTEGER :: size_evc
!
CHARACTER (len=24) :: bgz_suffix
CHARACTER (len=24) :: bgz_suffix
!
!LOGICAL :: nlcc_any ! .T. if any atom-type has nlcc
!
@ -49,48 +49,48 @@ module lr_variables
! dvxc_s(:,:,:) ! nrxx, nspin, nspin)
!
!
real(kind=dp), allocatable :: becp1(:,:)
complex(kind=dp), allocatable :: becp1_c(:,:,:)
real(kind=dp), allocatable :: becp1_virt(:,:)
complex(kind=dp), allocatable :: becp1_c_virt(:,:,:)
real(kind=dp), ALLOCATABLE :: becp1(:,:)
COMPLEX(kind=dp), ALLOCATABLE :: becp1_c(:,:,:)
real(kind=dp), ALLOCATABLE :: becp1_virt(:,:)
COMPLEX(kind=dp), ALLOCATABLE :: becp1_c_virt(:,:,:)
!
complex(kind=dp), allocatable :: &
!
COMPLEX(kind=dp), ALLOCATABLE :: &
evc0(:,:,:), & ! the ground state wavefunctions (plane wave, band, k point)
evc0_virt(:,:,:), & ! unoccupied ground state wavefunctions (plane wave, band, k point)
sevc0(:,:,:), & ! S * ground state wavefunctions
sevc0_virt(:,:,:), & ! S * virtual ground state wavefunctions
evc1_old(:,:,:,:), & ! response wavefunctions in the pw basis (last
! index 1: q' using rotated SBR 2: p')
! index 1: q' using rotated SBR 2: p')
evc1(:,:,:,:), & ! " "
evc1_new(:,:,:,:), & ! " "
sevc1_new(:,:,:,:),& ! S * " "
d0psi(:,:,:,:) ! for saving the original starting vectors
!
complex(kind=dp), allocatable :: revc0(:,:,:) !ground state wavefunctions in real space
COMPLEX(kind=dp), ALLOCATABLE :: revc0(:,:,:) !ground state wavefunctions in real space
!
real(kind=dp), allocatable :: &
real(kind=dp), ALLOCATABLE :: &
rho_1(:,:), & ! response charge density in real space
!rho_tot(:), & ! ground state + resp. charge density in real space (obm: is it used at all?)
rho_1_tot(:,:) !response charge density (mode 2)
complex(kind=dp), allocatable :: &
rho_1_tot(:,:) !response charge density (mode 2)
COMPLEX(kind=dp), ALLOCATABLE :: &
rho_1_tot_im(:,:) !response charge density, imaginary part used in resonance condition
!
!integer, allocatable :: &
! igk_k(:,:),&
! igk_k(:,:),&
! npw_k(:)
!
integer :: &
!
INTEGER :: &
nbnd_total !Actual number of bands calculated by PWSCF (virtual+ocuppied)
!
integer, allocatable :: cube_save(:,:) !used in response charge density mode 1
INTEGER, ALLOCATABLE :: cube_save(:,:) !used in response charge density mode 1
!
complex(kind=dp), allocatable :: F(:,:,:) !the intensity of transition from valance state (first index)
! to conduction state (second index), for each polarization
COMPLEX(kind=dp), ALLOCATABLE :: F(:,:,:) !the intensity of transition from valance state (first index)
! to conduction state (second index), for each polarization
!direction (third index)
complex(kind=dp), allocatable :: R(:,:,:) !the oscillator strength from valanace state (first index)
! to conduction state (second index), for each polarization
COMPLEX(kind=dp), ALLOCATABLE :: R(:,:,:) !the oscillator strength from valanace state (first index)
! to conduction state (second index), for each polarization
!direction (third index)
!
!open shell related...
@ -98,10 +98,10 @@ module lr_variables
!real(kind=dp) :: lr_alpha_pv ! Spread in eigenvalues
!integer, allocatable :: nbnd_occ(:) !number of occupied points for the given k point
!integer, allocatable :: &
! igk_k(:,:),& ! The g<->k correspondance for each k point
! igk_k(:,:),& ! The g<->k correspondance for each k point
! npw_k(:) ! number of plane waves at each k point
! They are (used many times, it is much better to hold them in memory
! They are (used many times, it is much better to hold them in memory
!
!Lanczos Matrix
!
@ -115,16 +115,16 @@ module lr_variables
!
! Zeta is the \sum_valance (V^T_j * r_i ) where r_i is the density operator acting
! on ground state orbitals
!
! zeta.w_T gives the polarizability (w_T is the solution of
!
! zeta.w_T gives the polarizability (w_T is the solution of
! (\omega-L)e_1 = w_T , this is handled in a post processing program)
!
!
real(kind=dp), allocatable :: & ! (pol, iter)
alpha_store(:,:),&
real(kind=dp), ALLOCATABLE :: & ! (pol, iter)
alpha_store(:,:),&
beta_store(:,:),&
gamma_store(:,:)
complex(kind=dp), allocatable :: zeta_store(:,:,:) !polarization of external field, polarization of internal field, iteration number.
COMPLEX(kind=dp), ALLOCATABLE :: zeta_store(:,:,:) !polarization of external field, polarization of internal field, iteration number.
!
!The currently processed polarization direction and Lanczos iteration
!
@ -133,56 +133,56 @@ module lr_variables
! variables for diagonalising the coefficient matrix
!
real(kind=dp) :: lanc_norm
real(kind=dp), allocatable :: eval1(:),eval2(:)
real(kind=dp), allocatable :: vl(:,:),vr(:,:)
real(kind=dp), ALLOCATABLE :: eval1(:),eval2(:)
real(kind=dp), ALLOCATABLE :: vl(:,:),vr(:,:)
!
REAL(kind=dp) :: norm0(3)
REAL(kind=dp) :: norm0(3)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lr_input:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
logical :: restart ! set True if the calculation is a restart run
integer :: restart_step ! the amount of steps to write a restart file
LOGICAL :: restart ! set True if the calculation is a restart run
INTEGER :: restart_step ! the amount of steps to write a restart file
!
integer :: lr_verbosity ! verbosity level for linear response routines
INTEGER :: lr_verbosity ! verbosity level for linear response routines
!
integer :: test_case_no = 0 ! OBM, this dummy variable performs various tests
integer :: lr_io_level = 1 ! Controls disk io
INTEGER :: test_case_no = 0 ! OBM, this dummy variable performs various tests
INTEGER :: lr_io_level = 1 ! Controls disk io
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lr_control:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
integer :: charge_response ! A variable for calculating response charge density
INTEGER :: charge_response ! A variable for calculating response charge density
!
INTEGER :: itermax ! number of Lanczos vectors to be calculated
INTEGER :: itermax_int ! interpolated number of lanczos steps for Ritz vectors
LOGICAL :: ltammd ! Tarn-Darnkhoff approximation
LOGICAL :: no_hxc ! If .true. no hartree exchange correlation corrections will be considered.
LOGICAL :: project ! If .true. projections to read virtual states will be calculated
!
integer :: itermax ! number of Lanczos vectors to be calculated
integer :: itermax_int ! interpolated number of lanczos steps for Ritz vectors
logical :: ltammd ! Tarn-Darnkhoff approximation
logical :: no_hxc ! If .true. no hartree exchange correlation corrections will be considered.
logical :: project ! If .true. projections to read virtual states will be calculated
!
!
!integer :: ipol ! sets the polarization direction to be calculated. (Used as a variable if 4)
! ! 1=x 2=y 3=z 4=x,y,z
!
!integer :: grid_coarsening ! Coarses the real space grid (by dividing nr1x nr2x and nr3x by this value)
!
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lr_post:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!real(kind=dp) :: broadening !Broadening
integer :: plot_type ! Dumps rho as: 1=xyzd 2=xsf 3=cube
!real(kind=dp) :: broadening !Broadening
INTEGER :: plot_type ! Dumps rho as: 1=xyzd 2=xsf 3=cube
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Debugging subroutines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains
CONTAINS
!----------------------------------------------------------------------------
SUBROUTINE check_vector_gamma (x)
! Checks the inner product for a given vector, and its imaginary and real
@ -190,24 +190,24 @@ SUBROUTINE check_vector_gamma (x)
! input, evc
! output : screen output
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
use mp, only : mp_sum
use realus, only : npw_k
use gvect, only : gstart
use io_global, only : stdout
USE mp, ONLY : mp_sum
USE realus, ONLY : npw_k
USE gvect, ONLY : gstart
USE io_global, ONLY : stdout
IMPLICIT NONE
!input/output
complex(kind=dp),intent(in) :: x(:)
COMPLEX(kind=dp),INTENT(in) :: x(:)
!local
real(kind=dp) :: temp_gamma
real(kind=dp), external :: DDOT
real(kind=dp), EXTERNAL :: DDOT
temp_gamma = 2.D0*DDOT(2*npw_k(1),x(:),1,x(:),1)
if (gstart==2) temp_gamma = temp_gamma - dble(x(1))*dble(x(1))
IF (gstart==2) temp_gamma = temp_gamma - dble(x(1))*dble(x(1))
#ifdef __PARA
call mp_sum(temp_gamma, intra_pool_comm)
#endif
write(stdout,'("<x> = ",E15.8)') temp_gamma
CALL mp_sum(temp_gamma, intra_pool_comm)
#endif
WRITE(stdout,'("<x> = ",E15.8)') temp_gamma
END SUBROUTINE check_vector_gamma
!----------------------------------------------------------------------------
@ -217,54 +217,54 @@ SUBROUTINE check_vector_f (x)
! input, evc
! output : screen output
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
use mp, only : mp_sum
use realus, only : npw_k
use gvect, only : gstart
use io_global, only : stdout
USE mp, ONLY : mp_sum
USE realus, ONLY : npw_k
USE gvect, ONLY : gstart
USE io_global, ONLY : stdout
IMPLICIT NONE
!input/output
complex(kind=dp),intent(in) :: x(:)
COMPLEX(kind=dp),INTENT(in) :: x(:)
!local
complex(kind=dp) :: temp_f
complex(kind=dp), external :: ZDOTC
COMPLEX(kind=dp) :: temp_f
COMPLEX(kind=dp), EXTERNAL :: ZDOTC
temp_f = ZDOTC(npw_k(1),x(:),1,x(:),1)
#ifdef __PARA
call mp_sum(temp_f, intra_pool_comm)
#endif
write(stdout,'("<x> = ",2E15.8,1X)') temp_f
CALL mp_sum(temp_f, intra_pool_comm)
#endif
WRITE(stdout,'("<x> = ",2E15.8,1X)') temp_f
END SUBROUTINE check_vector_f
!----------------------------------------------------------------------------
SUBROUTINE check_all_bands_gamma (x,sx,nbnd1,nbnd2)
! Checks all bands of given KS states for orthoganilty
! Checks all bands of given KS states for orthoganilty
! input, evc and sevc
! output : screen output
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
use mp, only : mp_sum
use realus, only : npw_k
use io_global, only : stdout
use gvect, only : gstart
USE mp, ONLY : mp_sum
USE realus, ONLY : npw_k
USE io_global, ONLY : stdout
USE gvect, ONLY : gstart
IMPLICIT NONE
!input/output
integer,intent(in) :: nbnd1,nbnd2 !Total number of bands for x and sx
complex(kind=dp),intent(in) :: x(:,:), sx(:,:)
INTEGER,INTENT(in) :: nbnd1,nbnd2 !Total number of bands for x and sx
COMPLEX(kind=dp),INTENT(in) :: x(:,:), sx(:,:)
!local
integer :: ibnd, jbnd
INTEGER :: ibnd, jbnd
real(kind=dp) :: temp_gamma
real(kind=dp), external :: DDOT
real(kind=dp), EXTERNAL :: DDOT
do ibnd=1,nbnd1
do jbnd=ibnd,nbnd2
DO ibnd=1,nbnd1
DO jbnd=ibnd,nbnd2
!
temp_gamma = 2.D0*DDOT(2*npw_k(1),x(:,ibnd),1,sx(:,jbnd),1)
if (gstart==2) temp_gamma = temp_gamma - dble(x(1,ibnd))*dble(sx(1,jbnd))
IF (gstart==2) temp_gamma = temp_gamma - dble(x(1,ibnd))*dble(sx(1,jbnd))
#ifdef __PARA
call mp_sum(temp_gamma, intra_pool_comm)
#endif
write(stdout,'("<x,",I02,"|S|x,",I02,"> =",E15.8)') ibnd,jbnd,temp_gamma
enddo
enddo
CALL mp_sum(temp_gamma, intra_pool_comm)
#endif
WRITE(stdout,'("<x,",I02,"|S|x,",I02,"> =",E15.8)') ibnd,jbnd,temp_gamma
ENDDO
ENDDO
END SUBROUTINE check_all_bands_gamma
!----------------------------------------------------------------------------
SUBROUTINE check_density_gamma (rx,nbnd)
@ -272,40 +272,40 @@ SUBROUTINE check_density_gamma (rx,nbnd)
! input, revc
! output : screen output
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
use mp, only : mp_sum
use realus, only : npw_k
use wvfct, only : wg
use grid_dimensions, only : nrxx
use io_global, only : stdout
use cell_base, only : omega
USE mp, ONLY : mp_sum
USE realus, ONLY : npw_k
USE wvfct, ONLY : wg
USE grid_dimensions, ONLY : nrxx
USE io_global, ONLY : stdout
USE cell_base, ONLY : omega
IMPLICIT NONE
!input/output
integer,intent(in) :: nbnd !Total number of bands for x and sx
complex(kind=dp),intent(in) :: rx(:,:)
INTEGER,INTENT(in) :: nbnd !Total number of bands for x and sx
COMPLEX(kind=dp),INTENT(in) :: rx(:,:)
!local
integer :: ibnd
INTEGER :: ibnd
real(kind=dp) :: temp_gamma,w1,w2
do ibnd=1,nbnd,2
DO ibnd=1,nbnd,2
w1=wg(ibnd,1)/omega
!
if(ibnd<nbnd) then
IF(ibnd<nbnd) THEN
w2=wg(ibnd+1,1)/omega
else
ELSE
w2=w1
endif
temp_gamma=SUM(w1*DBLE(rx(1:nrxx,ibnd))*DBLE(rx(1:nrxx,ibnd))&
ENDIF
temp_gamma=sum(w1*dble(rx(1:nrxx,ibnd))*dble(rx(1:nrxx,ibnd))&
+w2*aimag(rx(1:nrxx,ibnd))*aimag(rx(1:nrxx,ibnd)))
#ifdef __PARA
call mp_sum(temp_gamma, intra_pool_comm)
#endif
write(stdout,'("Contribution of bands ",I02," and ",I02," to total density",E15.8)') ibnd,ibnd+1,temp_gamma
enddo
CALL mp_sum(temp_gamma, intra_pool_comm)
#endif
WRITE(stdout,'("Contribution of bands ",I02," and ",I02," to total density",E15.8)') ibnd,ibnd+1,temp_gamma
ENDDO
!
!
END SUBROUTINE check_density_gamma
!----------------------------------------------------------------------------
!----------------------------------------------------------------------------
end module lr_variables
END MODULE lr_variables
!----------------------------------------------------------------------------

124
TDDFPT/src/lr_write_restart.f90
View File

@ -1,52 +1,52 @@
!-----------------------------------------------------------------------
subroutine lr_write_restart()
SUBROUTINE lr_write_restart()
!---------------------------------------------------------------------
! ... reads in and stores the vectors necessary to
! ... reads in and stores the vectors necessary to
! ... restart the Lanczos recursion
!---------------------------------------------------------------------
!
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use io_files, only : tmp_dir, prefix, diropn
use lr_variables, only : beta_store, gamma_store, zeta_store, norm0, &
USE io_files, ONLY : tmp_dir, prefix, diropn
USE lr_variables, ONLY : beta_store, gamma_store, zeta_store, norm0, &
LR_polarization, LR_iteration, n_ipol,F,project,&
evc1,evc1_new,iunrestart, nwordrestart, rho_1_tot, rho_1_tot_im, &
nbnd_total, charge_response,lr_verbosity,&
bgz_suffix
use charg_resp, only : resonance_condition
use wvfct, only : nbnd, npwx, npw
use grid_dimensions, only : nrxx
USE charg_resp, ONLY : resonance_condition
USE wvfct, ONLY : nbnd, npwx, npw
USE grid_dimensions, ONLY : nrxx
USE io_global, ONLY : ionode
use klist, only : nks
USE klist, ONLY : nks
USE noncollin_module, ONLY : nspin_mag
USE io_global, ONLY : stdout
!
implicit none
IMPLICIT NONE
!
character(len=6), external :: int_to_char
CHARACTER(len=6), EXTERNAL :: int_to_char
!
!integer, intent(in) :: pol, iter
!
! local variables
!
integer :: i, j, pol_index,ibnd_occ,ibnd_virt
character(len=256) :: tempfile, filename
logical :: exst
INTEGER :: i, j, pol_index,ibnd_occ,ibnd_virt
CHARACTER(len=256) :: tempfile, filename
LOGICAL :: exst
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<lr_write_restart>")')
endif
ENDIF
!
!ionode only operations:
! Note: ionode only operations are carried out in tmp_dir not wfc_dir
!
pol_index=1 !if there is only one polarization dir, storage is one rank less
if ( n_ipol /= 1 ) pol_index=LR_polarization
IF ( n_ipol /= 1 ) pol_index=LR_polarization
#ifdef __PARA
if (ionode) then
IF (ionode) THEN
#endif
!
!Writing beta gamma and zeta
@ -56,51 +56,51 @@ subroutine lr_write_restart()
tempfile = trim(tmp_dir) // trim(filename)
!
!
open (158, file = tempfile, form = 'formatted', status = 'unknown')
OPEN (158, file = tempfile, form = 'formatted', status = 'unknown')
!
write(158,*) LR_iteration
WRITE(158,*) LR_iteration
!
write(158,*) norm0(pol_index)
WRITE(158,*) norm0(pol_index)
!
do i=1,LR_iteration
DO i=1,LR_iteration
!
write(158,*) beta_store(pol_index,i)
write(158,*) gamma_store(pol_index,i)
WRITE(158,*) beta_store(pol_index,i)
WRITE(158,*) gamma_store(pol_index,i)
!This is absolutely necessary for cross platform compatibilty
do j=1,n_ipol
write(158,*) zeta_store (pol_index,j,i)
end do
DO j=1,n_ipol
WRITE(158,*) zeta_store (pol_index,j,i)
ENDDO
!
end do
ENDDO
!
close(158)
CLOSE(158)
!
!Writing F
!
if (project) then
IF (project) THEN
filename = trim(prefix) // ".projection." // trim(int_to_char(LR_polarization))
tempfile = trim(tmp_dir) // trim(filename)
!
!
open (158, file = tempfile, form = 'formatted', status = 'unknown')
OPEN (158, file = tempfile, form = 'formatted', status = 'unknown')
!
write(158,*) LR_iteration
WRITE(158,*) LR_iteration
!
write(158,*) nbnd !number of filled bands
WRITE(158,*) nbnd !number of filled bands
!
write(158,*) nbnd_total !total number of bands
WRITE(158,*) nbnd_total !total number of bands
!
do ibnd_occ=1,nbnd
do ibnd_virt=1,(nbnd_total-nbnd)
write(158,*) F(ibnd_occ,ibnd_virt,pol_index)
enddo
enddo
DO ibnd_occ=1,nbnd
DO ibnd_virt=1,(nbnd_total-nbnd)
WRITE(158,*) F(ibnd_occ,ibnd_virt,pol_index)
ENDDO
ENDDO
!
close(158)
endif
CLOSE(158)
ENDIF
!
#ifdef __PARA
end if
ENDIF
#endif
!
! Parallel writing operations
@ -114,29 +114,29 @@ subroutine lr_write_restart()
!
nwordrestart = 2 * nbnd * npwx * nks
!
call diropn ( iunrestart, 'restart_lanczos.'//trim(int_to_char(LR_polarization)), nwordrestart, exst)
CALL diropn ( iunrestart, 'restart_lanczos.'//trim(int_to_char(LR_polarization)), nwordrestart, exst)
!
call davcio(evc1(:,:,:,1),nwordrestart,iunrestart,1,1)
call davcio(evc1(:,:,:,2),nwordrestart,iunrestart,2,1)
call davcio(evc1_new(:,:,:,1),nwordrestart,iunrestart,3,1)
call davcio(evc1_new(:,:,:,2),nwordrestart,iunrestart,4,1)
CALL davcio(evc1(:,:,:,1),nwordrestart,iunrestart,1,1)
CALL davcio(evc1(:,:,:,2),nwordrestart,iunrestart,2,1)
CALL davcio(evc1_new(:,:,:,1),nwordrestart,iunrestart,3,1)
CALL davcio(evc1_new(:,:,:,2),nwordrestart,iunrestart,4,1)
!
close( unit = iunrestart)
CLOSE( unit = iunrestart)
!
! Writing charge response density for restart
!
if (charge_response == 1 ) then
if (resonance_condition) then
call diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx*nspin_mag, exst)
call davcio(rho_1_tot_im(:,:),2*nrxx*nspin_mag,iunrestart,1,1)
close( unit = iunrestart)
else
call diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx*nspin_mag, exst)
call davcio(rho_1_tot(:,:),2*nrxx*nspin_mag,iunrestart,1,1)
close( unit = iunrestart)
endif
endif
IF (charge_response == 1 ) THEN
IF (resonance_condition) THEN
CALL diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx*nspin_mag, exst)
CALL davcio(rho_1_tot_im(:,:),2*nrxx*nspin_mag,iunrestart,1,1)
CLOSE( unit = iunrestart)
ELSE
CALL diropn ( iunrestart, 'restart_lanczos-rho_tot.'//trim(int_to_char(LR_polarization)), 2*nrxx*nspin_mag, exst)
CALL davcio(rho_1_tot(:,:),2*nrxx*nspin_mag,iunrestart,1,1)
CLOSE( unit = iunrestart)
ENDIF
ENDIF
!
return
end subroutine lr_write_restart
RETURN
END SUBROUTINE lr_write_restart
!-----------------------------------------------------------------------

4
TDDFPT/src/print_clock_lr.f90
View File

@ -64,7 +64,7 @@ SUBROUTINE print_clock_lr()
!CALL print_clock( 'lrcd_sp' )
!CALL print_clock( 'lrcd_usdens' )
!
IF (real_space_debug>0) then
IF (real_space_debug>0) THEN
WRITE( stdout, '(5X,"US routines, RS")' )
CALL print_clock ( 'realus' )
CALL print_clock ( 'betapointlist' )
@ -96,7 +96,7 @@ SUBROUTINE print_clock_lr()
!CALL print_clock( 'reduce' )
CALL print_clock( 'fft_scatter' )
!CALL print_clock( 'poolreduce' )
call print_clock ('mp_sum')
CALL print_clock ('mp_sum')
WRITE( stdout, * )
#endif
!

74
TDDFPT/src/sd0psi.f90
View File

@ -1,72 +1,72 @@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine sd0psi()
SUBROUTINE sd0psi()
!
! S * d0psi for US case
! S * d0psi for US case
!
! Modified by Osman Baris Malcioglu (2009)
#include "f_defs.h"
!
use klist, only : nks,xk
use lr_variables, only : n_ipol!, real_space
use lr_variables, only : d0psi
use uspp, only : vkb, nkb, okvan
use wvfct, only : nbnd, npwx
use control_flags, only : gamma_only
use becmod, only : bec_type, becp, calbec
USE klist, ONLY : nks,xk
USE lr_variables, ONLY : n_ipol!, real_space
USE lr_variables, ONLY : d0psi
USE uspp, ONLY : vkb, nkb, okvan
USE wvfct, ONLY : nbnd, npwx
USE control_flags, ONLY : gamma_only
USE becmod, ONLY : bec_type, becp, calbec
!use real_beta, only : ccalbecr_gamma,s_psir,fft_orbital_gamma,bfft_orbital_gamma
USE realus, ONLY : real_space, fft_orbital_gamma, initialisation_level, &
bfft_orbital_gamma, calbec_rs_gamma, add_vuspsir_gamma, v_loc_psir, &
s_psir_gamma, igk_k, npw_k, real_space_debug
USE lr_variables, ONLY : lr_verbosity
USE io_global, ONLY : stdout
!
implicit none
IMPLICIT NONE
!
integer :: ik, ip,ibnd
INTEGER :: ik, ip,ibnd
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<sd0psi>")')
endif
if ( nkb==0 .or. (.not.okvan) ) return
ENDIF
IF ( nkb==0 .or. (.not.okvan) ) RETURN
!
do ip=1,n_ipol
DO ip=1,n_ipol
!
if (gamma_only) then
IF (gamma_only) THEN
!
if (real_space_debug>4) then
do ibnd=1,nbnd,2
call fft_orbital_gamma(d0psi(:,:,1,ip),ibnd,nbnd)
call calbec_rs_gamma(ibnd,nbnd,becp%r)
call s_psir_gamma(ibnd,nbnd)
call bfft_orbital_gamma(d0psi(:,:,1,ip),ibnd,nbnd)
enddo
IF (real_space_debug>4) THEN
DO ibnd=1,nbnd,2
CALL fft_orbital_gamma(d0psi(:,:,1,ip),ibnd,nbnd)
CALL calbec_rs_gamma(ibnd,nbnd,becp%r)
CALL s_psir_gamma(ibnd,nbnd)
CALL bfft_orbital_gamma(d0psi(:,:,1,ip),ibnd,nbnd)
ENDDO
! makedo part until spsi is in place
!call s_psi(npwx,npw_k(1),nbnd,d0psi(:,:,:,ip),d0psi(:,:,:,ip))
else
ELSE
!call pw_gemm('Y',nkb,nbnd,npw_k(1),vkb,npwx,d0psi(:,:,:,ip),npwx,rbecp,nkb)
call calbec(npw_k(1),vkb,d0psi(:,:,1,ip),becp)
CALL calbec(npw_k(1),vkb,d0psi(:,:,1,ip),becp)
!notice the third index given as :, whereas in the above routine it is 1. Inquire.
! I think it is spin index, spin is not considered yet, leave it for later
!call s_psi(npwx,npw_k(1),nbnd,d0psi(:,:,:,ip),d0psi(:,:,:,ip))
call s_psi(npwx,npw_k(1),nbnd,d0psi(:,:,1,ip),d0psi(:,:,1,ip))
endif
CALL s_psi(npwx,npw_k(1),nbnd,d0psi(:,:,1,ip),d0psi(:,:,1,ip))
ENDIF
!
else
ELSE
!
do ik=1,nks
DO ik=1,nks
!
call init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
CALL init_us_2(npw_k(ik),igk_k(1,ik),xk(1,ik),vkb)
!call ccalbec(nkb,npwx,npw_k(ik),nbnd,becp,vkb,d0psi(:,:,ik,ip))
call calbec(npw_k(ik),vkb,d0psi(:,:,ik,ip),becp)
call s_psi(npwx,npw_k(ik),nbnd,d0psi(:,:,ik,ip),d0psi(:,:,ik,ip))
CALL calbec(npw_k(ik),vkb,d0psi(:,:,ik,ip),becp)
CALL s_psi(npwx,npw_k(ik),nbnd,d0psi(:,:,ik,ip),d0psi(:,:,ik,ip))
!
enddo
ENDDO
!
end if
ENDIF
!
end do
ENDDO
!
end subroutine sd0psi
END SUBROUTINE sd0psi
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

54
TDDFPT/src/stop_lr.f90
View File

@ -16,11 +16,11 @@ SUBROUTINE stop_lr( )
USE mp, ONLY : mp_end, mp_barrier
!
USE parallel_include
use lr_variables, only : n_ipol, LR_polarization, beta_store
use lr_variables, only : gamma_store, zeta_store, norm0, rho_1_tot
use lr_variables, only : lr_verbosity, itermax, bgz_suffix
USE lr_variables, ONLY : n_ipol, LR_polarization, beta_store
USE lr_variables, ONLY : gamma_store, zeta_store, norm0, rho_1_tot
USE lr_variables, ONLY : lr_verbosity, itermax, bgz_suffix
USE io_global, ONLY : ionode
use io_files, only : tmp_dir, prefix
USE io_files, ONLY : tmp_dir, prefix
USE io_global, ONLY : stdout
! For gaussian cube file
USE ions_base, ONLY : nat, ityp, atm, ntyp => nsp, tau
@ -28,51 +28,51 @@ SUBROUTINE stop_lr( )
!
IMPLICIT NONE
!
character(len=6), external :: int_to_char
CHARACTER(len=6), EXTERNAL :: int_to_char
!
character(len=256) :: filename
CHARACTER(len=256) :: filename
!
integer :: ip,i,j
INTEGER :: ip,i,j
!
!
If (lr_verbosity > 5) THEN
IF (lr_verbosity > 5) THEN
WRITE(stdout,'("<stop_lr>")')
endif
ENDIF
! I write the beta gamma and z coefficents to output directory for
! easier post processing. These can also be read from the output log file
#ifdef __PARA
if (ionode) then
IF (ionode) THEN
#endif
!
do ip=1,n_ipol
if (n_ipol==3) filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(ip))
if (n_ipol==1) filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(LR_polarization))
DO ip=1,n_ipol
IF (n_ipol==3) filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(ip))
IF (n_ipol==1) filename = trim(prefix) // trim(bgz_suffix) // trim(int_to_char(LR_polarization))
filename = trim(tmp_dir) // trim(filename)
!
!
open (158, file = filename, form = 'formatted', status = 'replace')
OPEN (158, file = filename, form = 'formatted', status = 'replace')
!
write(158,*) itermax
WRITE(158,*) itermax
!
write(158,*) norm0(ip)
WRITE(158,*) norm0(ip)
!
do i=1,itermax
DO i=1,itermax
!
write(158,*) beta_store(ip,i)
write(158,*) gamma_store(ip,i)
WRITE(158,*) beta_store(ip,i)
WRITE(158,*) gamma_store(ip,i)
!This is absolutely necessary for cross platform compatibilty
do j=1,n_ipol
write(158,*) zeta_store (ip,j,i)
end do
DO j=1,n_ipol
WRITE(158,*) zeta_store (ip,j,i)
ENDDO
!
end do
ENDDO
!
close(158)
CLOSE(158)
!
enddo
ENDDO
#ifdef __PARA
end if
ENDIF
#endif
!
! Deallocate lr variables

828
TDDFPT/tools/tddfpt_calculate_spectrum.f90
View File

File diff suppressed because it is too large Load Diff