FIXME : Add documentation
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(redist_type), | intent(inout) | :: | f | |||
integer, | intent(in), | dimension (f%from_low(1):, f%from_low(2):, f%from_low(3):) | :: | from_here | ||
integer, | intent(inout), | dimension (f%to_low(1):, f%to_low(2):, f%to_low(3):) | :: | to_here |
subroutine i_fill_3 (f, from_here, to_here)
use job_manage, only: time_message
use mp, only: iproc, nproc, send, receive, get_mp_times
implicit none
type (redist_type), intent (in out) :: f
integer, dimension (f%from_low(1):, &
f%from_low(2):, &
f%from_low(3):), intent (in) :: from_here
integer, dimension (f%to_low(1):, &
f%to_low(2):, &
f%to_low(3):), intent (in out) :: to_here
integer :: i, idp, ipto, ipfrom, iadp
real :: mp_total, mp_total_after
if (.not. using_measure_scatter) then
call time_message(.false.,time_redist,' Redistribute')
call get_mp_times(total_time = mp_total)
end if
! redistribute from local processor to local processor
do i = 1, f%from(iproc)%nn
to_here(f%to(iproc)%k(i),&
f%to(iproc)%l(i), &
f%to(iproc)%m(i)) &
= from_here(f%from(iproc)%k(i), &
f%from(iproc)%l(i), &
f%from(iproc)%m(i))
end do
! redistribute to idpth next processor from idpth preceding processor
! or redistribute from idpth preceding processor to idpth next processor
! to avoid deadlocks
do idp = 1, nproc-1
ipto = mod(iproc + idp, nproc)
ipfrom = mod(iproc + nproc - idp, nproc)
iadp = min(idp, nproc - idp)
! avoid deadlock AND ensure mostly parallel resolution
if (mod(iproc/iadp,2) == 0) then
! send to idpth next processor
if (f%from(ipto)%nn > 0) then
do i = 1, f%from(ipto)%nn
f%integer_buff(i) = from_here(f%from(ipto)%k(i), &
f%from(ipto)%l(i), &
f%from(ipto)%m(i))
end do
call send (f%integer_buff(1:f%from(ipto)%nn), ipto, idp)
end if
! receive from idpth preceding processor
if (f%to(ipfrom)%nn > 0) then
call receive (f%integer_buff(1:f%to(ipfrom)%nn), ipfrom, idp)
do i = 1, f%to(ipfrom)%nn
to_here(f%to(ipfrom)%k(i), &
f%to(ipfrom)%l(i), &
f%to(ipfrom)%m(i)) &
= f%integer_buff(i)
end do
end if
else
! receive from idpth preceding processor
if (f%to(ipfrom)%nn > 0) then
call receive (f%integer_buff(1:f%to(ipfrom)%nn), ipfrom, idp)
do i = 1, f%to(ipfrom)%nn
to_here(f%to(ipfrom)%k(i), &
f%to(ipfrom)%l(i), &
f%to(ipfrom)%m(i)) &
= f%integer_buff(i)
end do
end if
! send to idpth next processor
if (f%from(ipto)%nn > 0) then
do i = 1, f%from(ipto)%nn
f%integer_buff(i) = from_here(f%from(ipto)%k(i), &
f%from(ipto)%l(i), &
f%from(ipto)%m(i))
end do
call send (f%integer_buff(1:f%from(ipto)%nn), ipto, idp)
end if
end if
end do
if (.not. using_measure_scatter) then
call time_message(.false.,time_redist,' Redistribute')
call get_mp_times(total_time = mp_total_after)
time_redist_mpi = time_redist_mpi + (mp_total_after - mp_total)
end if
end subroutine i_fill_3