subroutine get_SBB_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, SH_R, SBB_R, &
v_matrix, scissors_shift, wigner_seitz, ws_distance, ws_region, num_bands, &
num_kpts, num_wann, have_disentangled, seedname, stdout, timer, error, comm)
!================================================!
!
! SBB_ab(R) = <0|s_a.H.(r-R)_b|R> is the Fourier transform of
! SBB_ab(k) = <u|s_a.H|del_b u> (a,b=x,y,z)
!
!================================================!
use w90_postw90_types, only: pw90_berry_mod_type, wigner_seitz_type
use w90_types, only: dis_manifold_type, kmesh_info_type, ws_distance_type, ws_region_type, &
print_output_type, timer_list_type
implicit none
! arguments
type(pw90_berry_mod_type), intent(in) :: pw90_berry
type(dis_manifold_type), intent(in) :: dis_manifold
type(kmesh_info_type), intent(in) :: kmesh_info
type(wigner_seitz_type), intent(in) :: wigner_seitz
type(ws_distance_type), intent(in) :: ws_distance
type(ws_region_type), intent(in) :: ws_region
type(print_output_type), intent(in) :: print_output
type(timer_list_type), intent(inout) :: timer
type(w90_comm_type), intent(in) :: comm
type(w90_error_type), allocatable, intent(out) :: error
integer, intent(in) :: num_bands, num_kpts, num_wann, stdout
!real(kind=dp), intent(in) :: eigval(:, :)
real(kind=dp), intent(in) :: scissors_shift
real(kind=dp), intent(in) :: kpt_latt(:, :)
complex(kind=dp), intent(in) :: v_matrix(:, :, :)
complex(kind=dp), allocatable, intent(in) :: SH_R(:, :, :, :)
complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm>
complex(kind=dp), allocatable :: SBB_R_temp(:, :, :)
complex(kind=dp), allocatable :: SBB_R_b(:, :, :, :, :)
logical, intent(in) :: have_disentangled
character(len=50), intent(in) :: seedname
! local variables
integer :: i, j, ii, jj, ir, m, n, a, b, nn2, ik, nb_tmp, nkp_tmp, &
nntot_tmp, sHu_in, qb2, winmin_q, winmin_qb2, w
integer :: ipol
integer, allocatable :: num_states(:)
integer, allocatable :: counts(:), displs(:)
complex(kind=dp), allocatable :: SBB_q_b(:, :, :, :, :, :)
complex(kind=dp), allocatable :: SBB_q(:, :, :, :, :)
complex(kind=dp), allocatable :: SBB_q_loc(:, :, :)
complex(kind=dp), allocatable :: Ho_q_qb2(:, :, :)
complex(kind=dp), allocatable :: H_q_qb2(:, :)
real(kind=dp), allocatable :: r0(:, :, :)
complex(kind=dp), allocatable :: phase1(:, :), phase2(:)
character(len=60) :: header
logical :: on_root = .false.
if (mpirank(comm) == 0) on_root = .true.
if (print_output%timing_level > 1 .and. print_output%iprint > 0) &
call io_stopwatch_start('get_oper: get_SBB_R', timer)
if (.not. allocated(SBB_R)) then
allocate (SBB_R(num_wann, num_wann, wigner_seitz%nrpts_pw90, 3, 3))
else
if (print_output%timing_level > 1 .and. print_output%iprint > 0) &
call io_stopwatch_stop('get_oper: get_SBB_R', timer)
return
end if
if (on_root) then
allocate (SBB_q_b(num_wann, num_wann, num_kpts, kmesh_info%nntot, 3, 3))
SBB_R = cmplx_0
else
allocate (SBB_q_b(1, 1, 1, kmesh_info%nntot, 3, 3))
end if
if (on_root) then
if (abs(scissors_shift) > 1.0e-7_dp) then
call set_error_fatal(error, 'Error: scissors correction not yet implemented for SBB_R', comm)
return
end if
allocate (Ho_q_qb2(num_bands, num_bands, 3))
allocate (H_q_qb2(num_wann, num_wann))
allocate (num_states(num_kpts))
allocate (phase1(num_wann, num_wann))
if (pw90_berry%transl_inv_full) then
allocate (r0(num_wann, num_wann, 3))
do j = 1, num_wann
do i = 1, num_wann
r0(i, j, :) = (wigner_seitz%wannier_centres_from_AA_R(:, i) + &
wigner_seitz%wannier_centres_from_AA_R(:, j))/2.0_dp
end do
end do
end if
do ik = 1, num_kpts
if (have_disentangled) then
num_states(ik) = dis_manifold%ndimwin(ik)
else
num_states(ik) = num_wann
end if
end do
open (newunit=sHu_in, file=trim(seedname)//".sHu", form='unformatted', &
status='old', action='read', err=111)
write (stdout, '(/a)', advance='no') &
' Reading sHu overlaps from '//trim(seedname)//'.sHu in get_SBB_R: '
read (sHu_in, err=112, end=112) header
write (stdout, '(a)') trim(header)
read (sHu_in, err=112, end=112) nb_tmp, nkp_tmp, nntot_tmp
if (nb_tmp .ne. num_bands) then
call set_error_fatal(error, trim(seedname)//'.sHu has not the right number of bands', comm)
return
end if
if (nkp_tmp .ne. num_kpts) then
call set_error_fatal(error, trim(seedname)//'.sHu has not the right number of k-points', comm)
return
end if
if (nntot_tmp .ne. kmesh_info%nntot) then
call set_error_fatal(error, trim(seedname)//'.sHu has not the right number of nearest neighbours', comm)
return
end if
SBB_q_b = cmplx_0
do ik = 1, num_kpts
call get_win_min(num_bands, dis_manifold, ik, winmin_q, have_disentangled)
do nn2 = 1, kmesh_info%nntot
if (pw90_berry%transl_inv_full) then
phase1 = (r0(:, :, 1)*kmesh_info%bk(1, nn2, ik) + &
r0(:, :, 2)*kmesh_info%bk(2, nn2, ik) + &
r0(:, :, 3)*kmesh_info%bk(3, nn2, ik))
phase1 = exp(cmplx_i*phase1)
else
phase1 = cmplx_1
end if
qb2 = kmesh_info%nnlist(ik, nn2)
call get_win_min(num_bands, dis_manifold, qb2, winmin_qb2, have_disentangled)
do ipol = 1, 3
!
! Read from .sHu file the matrices <u_q|s_a H_q|u_{q+b2}>
! between the original ab initio eigenstates
!
read (sHu_in, err=112, end=112) &
((Ho_q_qb2(n, m, ipol), n=1, num_bands), m=1, num_bands)
! pw2wannier90 is coded a bit strangely, so here we take the transpose
Ho_q_qb2(:, :, ipol) = transpose(Ho_q_qb2(:, :, ipol))
end do
H_q_qb2(:, :) = cmplx_0
do ipol = 1, 3
do m = 1, num_wann
do n = 1, num_wann
do i = 1, num_states(ik)
ii = winmin_q + i - 1
do j = 1, num_states(qb2)
jj = winmin_qb2 + j - 1
H_q_qb2(n, m) = H_q_qb2(n, m) &
+ conjg(v_matrix(i, n, ik)) &
*Ho_q_qb2(ii, jj, ipol) &
*v_matrix(j, m, qb2)
end do
end do
end do
end do
do b = 1, 3
nn2o = kmesh_info%nninv(nn2, ik)
SBB_q_b(:, :, ik, nn2o, ipol, b) = SBB_q_b(:, :, ik, nn2o, ipol, b) + &
cmplx_i*phase1(:, :)*kmesh_info%wb(nn2)*kmesh_info%bk(b, nn2, ik)*H_q_qb2(:, :)
end do
end do !ipol
end do !nn2
end do !ik
close (sHu_in)
deallocate (phase1)
end if !on_root
if (pw90_berry%transl_inv_full) then
if (.not. allocated(SH_R)) then
call set_error_fatal(error, 'transl_inv_full=T for SBB_R needs SH_R', comm)
end if
allocate (counts(0:mpisize(comm) - 1))
allocate (displs(0:mpisize(comm) - 1))
w = num_wann*num_wann
call comms_array_split(num_kpts, counts, displs, comm)
allocate (SBB_q_loc(num_wann, num_wann, counts(mpirank(comm))))
allocate (SBB_R_temp(num_wann, num_wann, wigner_seitz%nrpts))
if (on_root) then
allocate (SBB_R_b(num_wann, num_wann, wigner_seitz%nrpts_pw90, 3, 3))
allocate (phase2(wigner_seitz%nrpts_pw90))
end if
do b = 1, 3
do ipol = 1, 3
do nn2 = 1, kmesh_info%nntot
call comms_scatterv(SBB_q_loc, w*counts(mpirank(comm)), SBB_q_b(:, :, :, nn2, ipol, b), w*counts, w*displs, error, comm)
call fourier_loc_q_to_R(num_kpts, counts, displs, mpirank(comm), wigner_seitz%nrpts, wigner_seitz%irvec, &
kpt_latt, SBB_q_loc, SBB_R_temp)
call comms_reduce(SBB_R_temp(1, 1, 1), num_wann*num_wann*wigner_seitz%nrpts, 'SUM', error, comm)
if (on_root) then
! Apply degeneracy factor and reorder according to the wigner-seitz vectors
call operator_wigner_setup(ws_distance, ws_region, wigner_seitz, num_wann, SBB_R_temp, SBB_R_b(:, :, :, ipol, b))
phase2 = -0.5_dp*(wigner_seitz%crvec_pw90(1, :)*kmesh_info%bk(1, nn2, 1) + &
wigner_seitz%crvec_pw90(2, :)*kmesh_info%bk(2, nn2, 1) + &
wigner_seitz%crvec_pw90(3, :)*kmesh_info%bk(3, nn2, 1))
phase2 = exp(cmplx_i*phase2)
SBB_R(:, :, :, ipol, b) = SBB_R(:, :, :, ipol, b) + &
SBB_R_b(:, :, :, ipol, b)*spread(spread(phase2, 1, num_wann), 1, num_wann)
end if
end do
end do
end do
deallocate (SBB_q_loc)
deallocate (SBB_R_temp)
if (on_root) then
deallocate (phase2)
deallocate (SBB_q_b)
deallocate (SBB_R_b)
do b = 1, 3
do ipol = 1, 3
do ir = 1, wigner_seitz%nrpts_pw90
SBB_R(:, :, ir, ipol, b) = SBB_R(:, :, ir, ipol, b) + &
(r0(:, :, b) - 0.5_dp*wigner_seitz%crvec_pw90(b, ir))*SH_R(:, :, ir, ipol)
end do
end do
end do
end if
else
allocate (SBB_q(num_wann, num_wann, num_kpts, 3, 3))
if (on_root) then
SBB_q = sum(SBB_q_b, 4)
deallocate (SBB_q_b)
end if
!
allocate (counts(0:mpisize(comm) - 1))
allocate (displs(0:mpisize(comm) - 1))
w = num_wann*num_wann
call comms_array_split(num_kpts, counts, displs, comm)
allocate (SBB_q_loc(num_wann, num_wann, counts(mpirank(comm))))
allocate (SBB_R_temp(num_wann, num_wann, wigner_seitz%nrpts))
do b = 1, 3
do ipol = 1, 3
call comms_scatterv(SBB_q_loc, w*counts(mpirank(comm)), SBB_q(:, :, :, ipol, b), w*counts, w*displs, error, comm)
call fourier_loc_q_to_R(num_kpts, counts, displs, mpirank(comm), wigner_seitz%nrpts, wigner_seitz%irvec, &
kpt_latt, SBB_q_loc, SBB_R_temp)
call comms_reduce(SBB_R_temp(1, 1, 1), num_wann*num_wann*wigner_seitz%nrpts, 'SUM', error, comm)
if (on_root) then
! Apply degeneracy factor and reorder according to the wigner-seitz vectors
call operator_wigner_setup(ws_distance, ws_region, wigner_seitz, num_wann, SBB_R_temp, SBB_R(:, :, :, ipol, b))
end if
end do
end do
deallocate (SBB_q_loc)
deallocate (SBB_q)
deallocate (SBB_R_temp)
end if
call comms_bcast(SBB_R(1, 1, 1, 1, 1), num_wann*num_wann*wigner_seitz%nrpts_pw90*3*3, error, comm)
if (allocated(error)) return
if (print_output%timing_level > 1 .and. print_output%iprint > 0) &
call io_stopwatch_stop('get_oper: get_SBB_R', timer)
return
deallocate (SBB_R_temp)
111 call set_error_file(error, 'Error: Problem opening input file '//trim(seedname)//'.sHu', comm)
return
112 call set_error_file(error, 'Error: Problem reading input file '//trim(seedname)//'.sHu', comm)
return
end subroutine get_SBB_R
