subroutine determ_projection_no_death()
! This subroutine gathers together partial_determ_vecs from each processor so
! that the full vector for the whole deterministic space is stored on each processor.
! It then performs the deterministic multiplication of the projector on this full vector.
use DetBitOps, only: DetBitEQ
use FciMCData, only: SemiStoch_Comms_Time
use FciMCData, only: SemiStoch_Multiply_Time
use Parallel_neci, only: MPIBarrier, MPIAllGatherV
integer :: i, j, ierr, run, part_type
do run = 1, size(cs_replicas)
associate(rep => cs_replicas(run))
call MPIBarrier(ierr)
call set_timer(SemiStoch_Comms_Time)
call MPIAllGatherV(rep%partial_determ_vecs, rep%full_determ_vecs, &
rep%determ_sizes, rep%determ_displs)
call halt_timer(SemiStoch_Comms_Time)
call set_timer(SemiStoch_Multiply_Time)
if (rep%determ_sizes(iProcIndex) >= 1) then
! Perform the multiplication.
rep%partial_determ_vecs = 0.0_dp
#ifdef CMPLX_
block
integer :: r_pt, i_pt
do i = 1, rep%determ_sizes(iProcIndex)
do j = 1, rep%sparse_core_ham(i)%num_elements
do r_pt = rep%min_part(), rep%max_part(), 2
i_pt = r_pt + 1
rep%partial_determ_vecs(r_pt, i) = rep%partial_determ_vecs(r_pt, i) &
- Real(rep%sparse_core_ham(i)%elements(j)) &
* rep%full_determ_vecs(r_pt, rep%sparse_core_ham(i)%positions(j)) &
+ Aimag(rep%sparse_core_ham(i)%elements(j)) &
* rep%full_determ_vecs(i_pt, rep%sparse_core_ham(i)%positions(j))
rep%partial_determ_vecs(i_pt, i) = rep%partial_determ_vecs(i_pt, i) &
- Aimag(rep%sparse_core_ham(i)%elements(j)) &
* rep%full_determ_vecs(r_pt, rep%sparse_core_ham(i)%positions(j)) &
- Real(rep%sparse_core_ham(i)%elements(j)) &
* rep%full_determ_vecs(i_pt, rep%sparse_core_ham(i)%positions(j))
end do
end do
end do
end block
#else
do i = 1, rep%determ_sizes(iProcIndex)
do j = 1, rep%sparse_core_ham(i)%num_elements
rep%partial_determ_vecs(:, i) = rep%partial_determ_vecs(:, i) &
- rep%sparse_core_ham(i)%elements(j) &
* rep%full_determ_vecs(:, rep%sparse_core_ham(i)%positions(j))
end do
end do
#endif
! Remove contribution from the diagonal elements, since the
! propagator has no diagonal.
do i = 1, rep%determ_sizes(iProcIndex)
rep%partial_determ_vecs(:, i) = rep%partial_determ_vecs(:, i) &
+ rep%core_ham_diag(i) &
* rep%full_determ_vecs(:, i + rep%determ_displs(iProcIndex))
end do
! Now multiply the vector by tau to get the final projected vector.
rep%partial_determ_vecs = &
rep%partial_determ_vecs * tau
do i = 1, rep%determ_sizes(iProcIndex)
if (tSkipRef(run) .and. DetBitEQ(CurrentDets(:, rep%indices_of_determ_states(i)), &
iLutRef(:, run), nIfD)) then
rep%partial_determ_vecs(:, i) = 0.0_dp
end if
end do
end if
call halt_timer(SemiStoch_Multiply_Time)
end associate
end do
end subroutine determ_projection_no_death