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

Graph comminication with init is workins... kind of. Runs but sometimes we get errors

Browse Source
scr-persistent-collective
Soren Rasmussen 6 years ago
parent 47325ab9ee
commit f8b25d926d
1 changed files with 306 additions and 100 deletions
Show Stats Download Patch File Download Diff File

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

@ -119,14 +119,30 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
logical :: swap_persistent
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
! TODO: get_mpic should be used to get dist_graph_comm, but for now this works
swap_persistent = iand(flag,psb_swap_persistent_) /= 0
if (swap_persistent) then
if (allocated(desc_a%dist_graph_comm)) then
! print *, "desc_a%dist_graph_comm", desc_a%dist_graph_comm
icomm = desc_a%dist_graph_comm
else
print *, "ERROR: desc_a%dist_graph_comm not allocated but swap persistent flag passed"
goto 9999
end if
end if
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -206,13 +222,22 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpk_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
& err_act, i, ii, ri, si, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n, ierr
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
& albf,do_send,do_recv, swap_persistent, do_persistent
logical, parameter :: usersend=.false., debug=.false.
integer(psb_ipk_), allocatable :: snd_counts(:), rcv_counts(:), &
snd_displs(:), rcv_displs(:), snd_to(:), rcv_from(:), snd_ws(:), rcv_ws(:)
character(len=20) :: name
!remove
integer :: status(MPI_STATUS_SIZE), string_len, num_neighbors, snd_count, rcv_count
character(len=2*MPI_MAX_ERROR_STRING) :: mpistring
logical :: weight
!character :: mpistring(16384)
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
@ -220,6 +245,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
icomm = iicomm
call psb_info(ictxt,me,np)
! print *, me, ": psi_dswapdata.F90:psi_dswap_vidx_vect" ! artless
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -231,13 +257,192 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
swap_persistent = iand(flag,psb_swap_persistent_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
do_persistent = swap_persistent
totrcv_ = totrcv * n
totsnd_ = totsnd * n
call idx%sync()
! check do_persistent twice, here and calling psi_dswapdata_vect, redudent but needed for now
if (do_persistent) then
! if not allocated, allocate buffers and create request
if (.not. allocated(y%sndbuf)) then
allocate(y%sndbuf(totsnd))
allocate(y%rcvbuf(totrcv))
! allocate(y%sndbuf(4))
! allocate(y%rcvbuf(4))
si = 1 ! sndbuf index
ri = 1 ! rcvbuf index
! y%sndbuf = 10 + me ! remove this after working
y%rcvbuf = -1 ! remove this after working
! call MPI_Graph_neighbors_count(icomm, me, num_neighbors, ierr)
! print *, me, "~~~~~ NUM NEIGHBORS = ", num_neighbors
call MPI_Dist_graph_neighbors_count(icomm, rcv_count, snd_count, weight, ierr)
allocate(rcv_from(rcv_count), rcv_ws(rcv_count), snd_to(snd_count), snd_ws(snd_count))
call MPI_Dist_graph_neighbors(icomm, rcv_count, rcv_from, rcv_ws, snd_count, snd_to, &
snd_ws, ierr)
allocate(snd_counts(snd_count), rcv_counts(rcv_count), &
snd_displs(snd_count), rcv_displs(rcv_count))
! old
! allocate(snd_counts(0:np-1), rcv_counts(0:np-1), &
! snd_displs(0:np-1), rcv_displs(0:np-1))
snd_counts=0
rcv_counts=0
snd_displs=0
rcv_displs=0
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ !
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
do ii=1, snd_count
if (rcv_from(ii) == proc_to_comm) then
rcv_counts(ii) = nerv
rcv_counts(ii) = 4
rcv_displs(ii) = si - 1
end if
if (snd_to(ii) == proc_to_comm) then
snd_counts(ii) = nesd
snd_counts(ii) = 4
snd_displs(ii) = si - 1
end if
end do
! prepare sndbuf
! si = si + 1
do ii=0,nesd-1
! y%sndbuf(si) = y%v(idx%v(ii+snd_pt))
y%sndbuf(si) = me + 10! si
si = si + 1
end do
! subroutine psi_dgthv(n,idx,alpha,x,beta,y) ! THIS THIS
! y = beta*y(1:n) + alpha*x(idx(1:n))
! print *, y%combuf , idx // index of y
! print *, "```idx_pt = ", idx_pt, "nesd = ", nesd
! print *, me, ":::::::pnti=", pnti, "proc_to_comm=", proc_to_comm,"nerv=", &
! nerv , "nesd=", nesd, "idx_pt=",idx_pt , "snd_pt=",snd_pt, &
! "rcv_pt=", rcv_pt
! print *, me, ":y%v", y%v
pnti = pnti + nerv + nesd + 3
end do
! code for this in ~/src/psblas/psblas3/base/internals/psi_desc_impl.f90
print *, me, ":totxch=", totxch,"totsnd", totsnd, "totrcv", totrcv
print *, me, ": rcv_count = ", rcv_count, "snd_count = ", snd_count
print *, me, ": rcv_from =", rcv_from, "snd_to =", snd_to
print *, me, ":snd_counts", snd_counts, "snd_displs = ",snd_displs, &
"rcv_counts", rcv_counts, "rcv_displs",rcv_displs
allocate(y%init_request)
y%init_request = -1
call MPIX_Neighbor_alltoallv_init(y%sndbuf, snd_counts, snd_displs, &
MPI_DOUBLE_PRECISION, y%rcvbuf, rcv_counts, rcv_displs, &
MPI_DOUBLE_PRECISION, icomm, MPI_INFO_NULL, &
! MPI_REAL, y%rcvbuf, rcv_counts, rcv_displs, &
! MPI_REAL, icomm, MPI_INFO_NULL, &
y%init_request, ierr)
if (ierr .ne. 0) then
print *, "ERROR: MPIX_Neighbor_alltoallvinit ierr = ", ierr
goto 9999
end if
! print *, me, ":y%init_request = ", y%init_request
deallocate(snd_counts, rcv_counts, snd_displs, rcv_displs)
else ! send and recv buffers exist, need to pack them
print *, "!!!!!!!!!!!!!!!ELSE"
end if
if (me == 3) then
! print *, me,"PRE: y%sndbuf=", y%sndbuf!, "y%rcvbuf=",y%rcvbuf
end if
! start communication
if (.not. allocated(y%init_request)) then
print *, "error: y%init_request should be allocated"
goto 9999
end if
call MPI_Start(y%init_request, ierr)
if (ierr .ne. 0) then
print *, "ERROR: MPI_Start ierr = ", ierr
goto 9999
end if
call MPI_Wait(y%init_request, status, ierr)
print *, me,": Y%SNDBUF=", y%sndbuf, "Y%RCVBUF=",y%rcvbuf
if (status(MPI_ERROR) .ne. 0) then
! print *, me,"ERROR: Y%SNDBUF=", y%sndbuf, "Y%RCVBUF=",y%rcvbuf
print *, me, "---ERROR---"
print *, "----"
! call MPI_Error_string(status(MPI_ERROR), mpistring, string_len, ierr)
! print *, "MPI_Error_string = ", mpistring(:string_len)
print *, "ERROR: rank ",me,"has MPI_Wait status(MPI_ERROR) = ", status(MPI_ERROR)
! goto 9999
end if
if (me == 1) then
! print *, me,"POST: y%sndbuf=", y%sndbuf, "y%rcvbuf=",y%rcvbuf
! print *, me,"POST: y%rcvbuf=",y%rcvbuf
end if
! print *, me,"POST: y%rcvbuf=",y%rcvbuf(:4)
end if
! Then gather for sending.
!
! pnti = 1
! snd_pt = totrcv_+1
! rcv_pt = 1
! do i=1, totxch
! nerv = idx%v(pnti+psb_n_elem_recv_)
! nesd = idx%v(pnti+nerv+psb_n_elem_send_)
! idx_pt = 1+pnti+nerv+psb_n_elem_send_
! call y%gth(idx_pt,snd_pt,nesd,idx)
! rcv_pt = rcv_pt + n*nerv
! snd_pt = snd_pt + n*nesd
! pnti = pnti + nerv + nesd + 3
! end do
! from later, is this needed??
! pnti = 1
! snd_pt = 1
! rcv_pt = 1
! do i=1, totxch
! proc_to_comm = idx%v(pnti+psb_proc_id_)
! nerv = idx%v(pnti+psb_n_elem_recv_)
! nesd = idx%v(pnti+nerv+psb_n_elem_send_)
! idx_pt = 1+pnti+psb_n_elem_recv_
! snd_pt = 1+pnti+nerv+psb_n_elem_send_
! rcv_pt = 1+pnti+psb_n_elem_recv_
! if (debug) write(0,*)me,' Received from: ',prcid(i),&
! & y%combuf(rcv_pt:rcv_pt+nerv-1)
! call y%sct(rcv_pt,nerv,idx,beta)
! pnti = pnti + nerv + nesd + 3
! end do
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
@ -464,6 +669,7 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
print *, me, ": psi_dswapdata.F90:psi_dswapdata_multivect"
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -557,6 +763,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
icomm = iicomm
call psb_info(ictxt,me,np)
print *, me, ": psi_dswapdata.F90:psi_dswap_vidx_multivect"
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -763,4 +970,3 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
return
end subroutine psi_dswap_vidx_multivect

Write Preview
Loading…
Cancel
Save