fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

adding lots of good stuff

Browse Source
scr-persistent-collective
Soren Rasmussen 7 years ago
parent 468f353995
commit 064bca74db
3 changed files with 213 additions and 225 deletions
Show Stats Download Patch File Download Diff File

168
base/comm/internals/psi_dswapdata.F90
Unescape Escape View File

@ -1,5 +1,5 @@
! debug out-of-bound ! debug out-of-bound
#define DBG_OOB ! #define DBG_OOB
! debug personal ! debug personal
! #define DBG_PER ! #define DBG_PER
@ -113,19 +113,19 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
#endif #endif
#include "scorep/SCOREP_User.inc" #include "scorep/SCOREP_User.inc"
integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:) real(psb_dpk_), target :: work(:)
type(psb_desc_type), target :: desc_a type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data integer(psb_ipk_), optional :: data
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
class(psb_i_base_vect_type), pointer :: d_vidx class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name character(len=20) :: name
logical :: swap_persistent logical :: swap_persistent, swap_nonpersistent, do_alltoallv
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
@ -136,7 +136,9 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
icomm = desc_a%get_mpic() icomm = desc_a%get_mpic()
! TODO: get_mpic should be used to get dist_graph_comm, but for now this works ! TODO: get_mpic should be used to get dist_graph_comm, but for now this works
swap_persistent = iand(flag,psb_swap_persistent_) /= 0 swap_persistent = iand(flag,psb_swap_persistent_) /= 0
if (swap_persistent) then swap_nonpersistent = iand(flag,psb_swap_nonpersistent_) /= 0
do_alltoallv = swap_persistent .or. swap_nonpersistent
if (do_alltoallv) then
if (allocated(desc_a%dist_graph_comm)) then if (allocated(desc_a%dist_graph_comm)) then
! print *, "desc_a%dist_graph_comm", desc_a%dist_graph_comm ! print *, "desc_a%dist_graph_comm", desc_a%dist_graph_comm
icomm = desc_a%dist_graph_comm icomm = desc_a%dist_graph_comm
@ -231,13 +233,14 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
& err_act, i, j, ii, ri, si, idx_pt, totsnd_, totrcv_,& & err_act, i, j, ii, ri, si, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n, ierr & snd_pt, rcv_pt, pnti, n, ierr
logical :: swap_mpi, swap_sync, swap_send, swap_recv,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv, swap_persistent, do_persistent & albf,do_send,do_recv, &
do_alltoallv, swap_persistent, swap_nonpersistent
logical, parameter :: usersend=.false., debug=.false. logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name character(len=20) :: name
!remove !remove
integer :: status(MPI_STATUS_SIZE) integer :: status(MPI_STATUS_SIZE)
real :: start_t, finish_t real(psb_dpk_) :: start_t, finish_t, start_comm_t, end_comm_t
logical :: weight logical :: weight
real(psb_dpk_) :: tmp real(psb_dpk_) :: tmp
! score-p declaration ! score-p declaration
@ -260,14 +263,15 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
endif endif
n=1 n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0
swap_persistent = iand(flag,psb_swap_persistent_) /= 0 swap_persistent = iand(flag,psb_swap_persistent_) /= 0
swap_nonpersistent = iand(flag,psb_swap_nonpersistent_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv do_recv = swap_mpi .or. swap_sync .or. swap_recv
do_persistent = swap_persistent do_alltoallv = swap_persistent .or. swap_nonpersistent
totrcv_ = totrcv * n totrcv_ = totrcv * n
totsnd_ = totsnd * n totsnd_ = totsnd * n
@ -276,19 +280,17 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! TODO check do_persistent twice, here and calling psi_dswapdata_vect, ! TODO check do_persistent twice, here and calling psi_dswapdata_vect,
! redudent but needed for now ! redudent but needed for now
if (do_persistent) then if (do_alltoallv) then
! if not allocated, allocate buffers and create request
if (.not. allocated(y%p)) then if (.not. allocated(y%p)) then
allocate(y%p) allocate(y%p)
end if end if
if (.not. allocated(y%p%sndbuf)) then if (.not. allocated(y%p%sndbuf)) then
! allocate time counters
allocate(y%p%alltoall_comm_time, y%p%total_time)
y%p%alltoall_comm_time = 0
! allocate buffers
allocate(y%p%sndbuf(totsnd), y%p%rcvbuf(totrcv)) allocate(y%p%sndbuf(totsnd), y%p%rcvbuf(totrcv))
allocate(y%p%rcv_count, y%p%snd_count) allocate(y%p%rcv_count, y%p%snd_count)
#ifdef DBG_OOB ! debug out-of-bound
y%p%sndbuf = 0
y%p%rcvbuf = me + 10
#endif
! get number of neighbors and graph so we know who to communicate with ! get number of neighbors and graph so we know who to communicate with
call MPI_Dist_graph_neighbors_count(icomm, y%p%rcv_count, & call MPI_Dist_graph_neighbors_count(icomm, y%p%rcv_count, &
y%p%snd_count, weight, ierr) ! should weight go into psb_d_persis_vect_type?? y%p%snd_count, weight, ierr) ! should weight go into psb_d_persis_vect_type??
@ -339,49 +341,41 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
#ifdef DBG_PER ! #ifdef DBG_PER
print *, me, ":totxch=", totxch,"totsnd", totsnd, "totrcv", totrcv ! print *, me, ": totxch", totxch,"total to send", totsnd, "total to recv", totrcv
print *, me, ": rcv_count = ", y%p%rcv_count, "snd_count = ", y%p%snd_count ! print *, me, ": rcv_count = ", y%p%rcv_count, "snd_count = ", y%p%snd_count
print *, me, ": y%p%rcv_from =", y%p%rcv_from, "y%p%snd_to =", y%p%snd_to ! print *, me, ":y%p%snd_displs = ",y%p%snd_displs, &
print *, me, ":y%p%snd_counts", y%p%snd_counts, "y%p%snd_displs = ",y%p%snd_displs, & ! "y%p%rcv_displs",y%p%rcv_displs
"y%p%rcv_counts", y%p%rcv_counts, "y%p%rcv_displs",y%p%rcv_displs ! #endif
#endif
! ----------------------------
allocate(y%p%init_request) ! print *, me, ": totsnd=",totsnd ,"y%p%snd_to =", y%p%snd_to, &
y%p%init_request = -1 ! "y%p%snd_counts = ", y%p%snd_counts
! print *, me, ": totrcv=",totrcv,"y%p%rcv_from =", y%p%rcv_from, &
! SCOREP_USER_REGION_BEGIN(MPIX_Neighbor_alltoallv_init_region, & ! "y%p%rcv_counts = ", y%p%rcv_counts
! "MPIX_Neighbor_alltoallv_init", SCOREP_USER_REGION_TYPE_FUNCTION) ! ----------------------------
! SCOREP_USER_REGION_BEGIN(artless_test, &
! "foo", SCOREP_USER_REGION_TYPE_COMMON)
call MPI_Barrier(MPI_COMM_WORLD,ierr) ! ----------------------------
call cpu_time(start_t) ! Persistant Request Creation
call MPIX_Neighbor_alltoallv_init(y%p%sndbuf, y%p%snd_counts, y%p%snd_displs, & ! ----------------------------
MPI_DOUBLE_PRECISION, y%p%rcvbuf, y%p%rcv_counts, y%p%rcv_displs, & if (swap_persistent) then
MPI_DOUBLE_PRECISION, icomm, MPI_INFO_NULL, & allocate(y%p%init_request)
y%p%init_request, ierr) y%p%init_request = -1
! SCOREP_USER_REGION_END(artless_test) start_t = MPI_Wtime()
! SCOREP_USER_REGION_END(MPIX_Neighbor_alltoallv_init_region) call MPIX_Neighbor_alltoallv_init(y%p%sndbuf, y%p%snd_counts, y%p%snd_displs, &
call cpu_time(finish_t) MPI_DOUBLE_PRECISION, y%p%rcvbuf, y%p%rcv_counts, y%p%rcv_displs, &
allocate(y%p%comm_create_time) MPI_DOUBLE_PRECISION, icomm, MPI_INFO_NULL, &
y%p%comm_create_time = finish_t - start_t y%p%init_request, ierr)
! print *,"cpu time of MPIX_Neighbor_alltoallv_init is", finish_t - start_t finish_t = MPI_Wtime()
allocate(y%p%request_create_time)
if (ierr .ne. 0) then y%p%request_create_time = finish_t - start_t
print *, "ERROR: MPIX_Neighbor_alltoallvinit ierr = ", ierr
goto 9999
end if end if
! ----------------------------
! ARTLESS: SENDBUF LOOKS OK HERE! ! if (ierr .ne. 0) then
! call MPI_Barrier(MPI_COMM_WORLD, ierr) ! print *, "ERROR: MPIX_Neighbor_alltoallvinit ierr = ", ierr
! write(*,'(I2 A)', advance='no') me, ": sndbuf = " ! goto 9999
! print '(104 F4.0)', y%p%sndbuf ! end if
! call MPI_Barrier(MPI_COMM_WORLD, ierr)
#ifdef DBG_PER
print* ,me, ": end MPIX_Neighbor_alltoallv_init"
#endif
else ! send and recv buffers exist, need to pack send buffer else ! send and recv buffers exist, need to pack send buffer
si = 1 ! sndbuf index si = 1 ! sndbuf index
pnti = 1 pnti = 1
@ -405,38 +399,24 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
end do end do
end if ! end packing phase end if ! end packing phase
! --- start communication ! ---- start communication ----
#ifdef DBG_PER start_comm_t = MPI_Wtime()
if (.not. allocated(y%p%init_request)) then ! ---- if persistant ----
print *, "error: y%p%init_request should be allocated" if (swap_persistent) then
goto 9999 call MPI_Start(y%p%init_request, ierr)
call MPI_Wait(y%p%init_request, status, ierr)
end if end if
#endif
call MPI_Start(y%p%init_request, ierr) ! ---- if non-persistent ----
#ifdef DBG_PER if (swap_nonpersistent) then
if (ierr .ne. 0) then call MPI_Neighbor_alltoallv(y%p%sndbuf, y%p%snd_counts, y%p%snd_displs, &
print *, "ERROR: rank ",me,"has MPI_Start status(MPI_ERROR) = ", & MPI_DOUBLE_PRECISION, y%p%rcvbuf, y%p%rcv_counts, y%p%rcv_displs, &
status(MPI_ERROR), "and ierr = ", ierr MPI_DOUBLE_PRECISION, icomm, ierr)
goto 9999
end if
#endif
call MPI_Wait(y%p%init_request, status, ierr)
#ifdef DBG_PER
if (ierr .ne. 0) then
print *, "ERROR: rank ",me,"has MPI_Wait status(MPI_ERROR) = ", &
status(MPI_ERROR), "and ierr = ", ierr
goto 9999
end if end if
#endif end_comm_t = MPI_Wtime() - start_comm_t
y%p%alltoall_comm_time = y%p%alltoall_comm_time + end_comm_t
! write(*,'(I2 A)', advance='no') me, "::::: rcvbuf ="
! print '(104 F4.0)', y%p%rcvbuf
! ----scatter/unpack buffer---- ! ----scatter/unpack buffer----
#ifdef DBG_PER
print*, me, ": begin scatter/unpack buffer"
#endif
pnti = 1 pnti = 1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch

12
base/comm/internals/psi_dswapdata_a.F90
Unescape Escape View File

@ -60,7 +60,7 @@
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
@ -108,6 +108,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
character(len=20) :: name character(len=20) :: name
print *, "psi_dswapdata_a.F90:psi_dswapdatam"
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
@ -189,6 +190,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
volatile :: sndbuf, rcvbuf volatile :: sndbuf, rcvbuf
#endif #endif
character(len=20) :: name character(len=20) :: name
print *, "psi_dswapdata_a.F90:psi_dswapidxm"
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
@ -582,6 +584,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
character(len=20) :: name character(len=20) :: name
print *, "psi_dswapdata_a.F90:psi_dswapdatav"
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
@ -674,6 +677,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
volatile :: sndbuf, rcvbuf volatile :: sndbuf, rcvbuf
#endif #endif
character(len=20) :: name character(len=20) :: name
print *, "psi_dswapdata_a.F90:psi_dswapidxv"
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
@ -717,8 +721,9 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch ! artless: this is what i want to do MPI_V for MPI_COMM_WORLD
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
@ -732,7 +737,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
print *, "---ARTLESS rcv_pt = ", rcv_pt, "snd_pt = ", snd_pt
end do end do
else else
@ -773,6 +778,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if

8
base/comm/psb_dhalo.f90
Unescape Escape View File

@ -74,6 +74,9 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw logical :: aliw
! print *, "======ARTLESS======"
! print *, "psb_dhalo.f90:78:psb_dhalo_vect"
name='psb_dhalov' name='psb_dhalov'
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -166,7 +169,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
! exchange halo elements ! exchange halo elements
if(tran_ == 'N') then if(tran_ == 'N') then
call psi_swapdata(imode,dzero,x%v,& call psi_swapdata(imode,dzero,x%v,&
& desc_a,iwork,info,data=data_) & desc_a,iwork,info,data=data_) ! artless: this gets called, desc_a has comm
else if((tran_ == 'T').or.(tran_ == 'C')) then else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,done,x%v,& call psi_swaptran(imode,done,x%v,&
& desc_a,iwork,info) & desc_a,iwork,info)
@ -214,7 +217,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw logical :: aliw
print *, "psb_dhalo.f90:psb_dhalo_multivect" ! artless
name='psb_dhalov' name='psb_dhalov'
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -333,4 +336,3 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
return return
end subroutine psb_dhalo_multivect end subroutine psb_dhalo_multivect

Write Preview
Loading…
Cancel
Save