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

psblas3:

Browse Source 
base/comm/internals/psi_cswapdata.F90
 base/comm/internals/psi_cswaptran.F90
 base/comm/internals/psi_dswapdata.F90
 base/comm/internals/psi_dswaptran.F90
 base/comm/internals/psi_iswapdata.F90
 base/comm/internals/psi_iswaptran.F90
 base/comm/internals/psi_sswapdata.F90
 base/comm/internals/psi_sswaptran.F90
 base/comm/internals/psi_zswapdata.F90
 base/comm/internals/psi_zswaptran.F90

Reworked communication internals to reduce malloc/free calls which
were harming GPU performance.
trunk
Salvatore Filippone 8 years ago
parent 854c3d8418
commit 609d924505
10 changed files with 515 additions and 600 deletions
Show Stats Download Patch File Download Diff File

112
base/comm/internals/psi_cswapdata.F90
Unescape Escape View File

@ -140,7 +140,6 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
@ -197,6 +196,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -230,7 +230,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -249,7 +248,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else
@ -310,7 +308,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -337,7 +334,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -348,7 +344,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -372,7 +367,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -407,7 +401,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
@ -438,7 +431,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -448,7 +440,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -457,7 +448,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -474,11 +464,8 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -604,7 +591,8 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -618,9 +606,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
@ -644,7 +630,6 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_cswapdatav
!
!
! Subroutine: psi_cswapdataidxv
@ -700,6 +685,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -708,8 +694,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -911,7 +896,6 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_complex_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
@ -1051,9 +1035,8 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1156,8 +1139,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -1170,18 +1152,21 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1324,16 +1309,19 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%sct(rcv_pt,nerv,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1355,10 +1343,9 @@ end subroutine psi_cswap_vidx_vect
! Subroutine: psi_cswapdata_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector.
! Takes care of Y an encaspulated vector.
!
!
!
subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswapdata_multivect
@ -1391,9 +1378,8 @@ subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1436,7 +1422,7 @@ end subroutine psi_cswapdata_multivect
! Subroutine: psi_cswap_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
@ -1464,8 +1450,8 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -1506,22 +1492,26 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
totrcv_ = totrcv * n
totsnd_ = totsnd * n
call idx%sync()
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1561,7 +1551,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
@ -1649,7 +1639,6 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
@ -1669,16 +1658,19 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

111
base/comm/internals/psi_cswaptran.F90
Unescape Escape View File

@ -157,7 +157,8 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_cswaptranm
subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidxm
use psb_error_mod
@ -209,11 +210,11 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
goto 9999
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
@ -242,10 +243,8 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
@ -265,7 +264,6 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
@ -657,9 +655,8 @@ end subroutine psi_cswaptranv
!
!
!
subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidxv
use psb_error_mod
@ -687,12 +684,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_, n
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -743,7 +734,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -857,7 +847,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -917,7 +906,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -962,7 +950,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
@ -979,12 +966,10 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
@ -1004,7 +989,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
@ -1028,10 +1012,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
return
end subroutine psi_ctranidxv
!
!
!
!
! Subroutine: psi_cswaptran_vect
@ -1131,6 +1111,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_ctran_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_c_base_vect_mod
@ -1191,18 +1172,21 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1248,7 +1232,6 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1351,16 +1334,19 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%sct(snd_pt,nesd,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1386,7 +1372,7 @@ end subroutine psi_ctran_vidx_vect
! Subroutine: psi_cswaptran_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector.
! Takes care of Y an encaspulated vector.
!
!
subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
@ -1461,14 +1447,13 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_cswaptran_multivect
!
!
! Subroutine: psi_ctran_vidx_vect
! Subroutine: psi_ctran_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
@ -1480,9 +1465,10 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_ctran_vidx_multivect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_c_base_vect_mod
use psb_c_base_multivect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1542,17 +1528,20 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1593,12 +1582,11 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1686,8 +1674,6 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
@ -1707,13 +1693,18 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

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

@ -140,7 +140,6 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
@ -197,6 +196,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -230,7 +230,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -249,7 +248,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else
@ -310,7 +308,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -337,7 +334,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -348,7 +344,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -372,7 +367,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -407,7 +401,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
@ -438,7 +431,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -448,7 +440,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -457,7 +448,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -474,11 +464,8 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -604,7 +591,8 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -618,9 +606,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
@ -644,7 +630,6 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_dswapdatav
!
!
! Subroutine: psi_dswapdataidxv
@ -700,6 +685,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -708,8 +694,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -911,7 +896,6 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_double_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
@ -1051,9 +1035,8 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1156,8 +1139,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -1170,18 +1152,21 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1324,16 +1309,19 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%sct(rcv_pt,nerv,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1355,10 +1343,9 @@ end subroutine psi_dswap_vidx_vect
! Subroutine: psi_dswapdata_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector.
! Takes care of Y an encaspulated vector.
!
!
!
subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswapdata_multivect
@ -1391,9 +1378,8 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1436,7 +1422,7 @@ end subroutine psi_dswapdata_multivect
! Subroutine: psi_dswap_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
@ -1464,8 +1450,8 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -1506,22 +1492,26 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
totrcv_ = totrcv * n
totsnd_ = totsnd * n
call idx%sync()
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1561,7 +1551,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
@ -1649,7 +1639,6 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
@ -1669,16 +1658,19 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

111
base/comm/internals/psi_dswaptran.F90
Unescape Escape View File

@ -157,7 +157,8 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_dswaptranm
subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidxm
use psb_error_mod
@ -209,11 +210,11 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
goto 9999
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
@ -242,10 +243,8 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
@ -265,7 +264,6 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
@ -657,9 +655,8 @@ end subroutine psi_dswaptranv
!
!
!
subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidxv
use psb_error_mod
@ -687,12 +684,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_, n
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -743,7 +734,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -857,7 +847,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -917,7 +906,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -962,7 +950,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
@ -979,12 +966,10 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
@ -1004,7 +989,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
@ -1028,10 +1012,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
return
end subroutine psi_dtranidxv
!
!
!
!
! Subroutine: psi_dswaptran_vect
@ -1131,6 +1111,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_dtran_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_d_base_vect_mod
@ -1191,18 +1172,21 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1248,7 +1232,6 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1351,16 +1334,19 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%sct(snd_pt,nesd,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1386,7 +1372,7 @@ end subroutine psi_dtran_vidx_vect
! Subroutine: psi_dswaptran_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector.
! Takes care of Y an encaspulated vector.
!
!
subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
@ -1461,14 +1447,13 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_dswaptran_multivect
!
!
! Subroutine: psi_dtran_vidx_vect
! Subroutine: psi_dtran_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
@ -1480,9 +1465,10 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_dtran_vidx_multivect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_d_base_vect_mod
use psb_d_base_multivect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1542,17 +1528,20 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1593,12 +1582,11 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1686,8 +1674,6 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
@ -1707,13 +1693,18 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

112
base/comm/internals/psi_iswapdata.F90
Unescape Escape View File

@ -140,7 +140,6 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
@ -197,6 +196,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -230,7 +230,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -249,7 +248,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else
@ -310,7 +308,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -337,7 +334,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -348,7 +344,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -372,7 +367,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -407,7 +401,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
@ -438,7 +431,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -448,7 +440,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -457,7 +448,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -474,11 +464,8 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -604,7 +591,8 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -618,9 +606,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
@ -644,7 +630,6 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_iswapdatav
!
!
! Subroutine: psi_iswapdataidxv
@ -700,6 +685,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -708,8 +694,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -911,7 +896,6 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
@ -1051,9 +1035,8 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1156,8 +1139,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -1170,18 +1152,21 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1324,16 +1309,19 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%sct(rcv_pt,nerv,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1355,10 +1343,9 @@ end subroutine psi_iswap_vidx_vect
! Subroutine: psi_iswapdata_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector.
! Takes care of Y an encaspulated vector.
!
!
!
subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdata_multivect
@ -1391,9 +1378,8 @@ subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1436,7 +1422,7 @@ end subroutine psi_iswapdata_multivect
! Subroutine: psi_iswap_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
@ -1464,8 +1450,8 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -1506,22 +1492,26 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
totrcv_ = totrcv * n
totsnd_ = totsnd * n
call idx%sync()
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1561,7 +1551,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
@ -1649,7 +1639,6 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
@ -1669,16 +1658,19 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

111
base/comm/internals/psi_iswaptran.F90
Unescape Escape View File

@ -157,7 +157,8 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_iswaptranm
subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidxm
use psb_error_mod
@ -209,11 +210,11 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
goto 9999
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
@ -242,10 +243,8 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
@ -265,7 +264,6 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
@ -657,9 +655,8 @@ end subroutine psi_iswaptranv
!
!
!
subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidxv
use psb_error_mod
@ -687,12 +684,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_, n
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -743,7 +734,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -857,7 +847,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -917,7 +906,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -962,7 +950,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
@ -979,12 +966,10 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
@ -1004,7 +989,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
@ -1028,10 +1012,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
return
end subroutine psi_itranidxv
!
!
!
!
! Subroutine: psi_iswaptran_vect
@ -1131,6 +1111,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_itran_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
@ -1191,18 +1172,21 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1248,7 +1232,6 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1351,16 +1334,19 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%sct(snd_pt,nesd,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1386,7 +1372,7 @@ end subroutine psi_itran_vidx_vect
! Subroutine: psi_iswaptran_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector.
! Takes care of Y an encaspulated vector.
!
!
subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
@ -1461,14 +1447,13 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_iswaptran_multivect
!
!
! Subroutine: psi_itran_vidx_vect
! Subroutine: psi_itran_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
@ -1480,9 +1465,10 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_itran_vidx_multivect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use psb_i_base_multivect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1542,17 +1528,20 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1593,12 +1582,11 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1686,8 +1674,6 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
@ -1707,13 +1693,18 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

112
base/comm/internals/psi_sswapdata.F90
Unescape Escape View File

@ -140,7 +140,6 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
@ -197,6 +196,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -230,7 +230,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -249,7 +248,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else
@ -310,7 +308,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -337,7 +334,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -348,7 +344,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -372,7 +367,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -407,7 +401,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
@ -438,7 +431,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -448,7 +440,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -457,7 +448,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -474,11 +464,8 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -604,7 +591,8 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -618,9 +606,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
@ -644,7 +630,6 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_sswapdatav
!
!
! Subroutine: psi_sswapdataidxv
@ -700,6 +685,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -708,8 +694,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -911,7 +896,6 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_real_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
@ -1051,9 +1035,8 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1156,8 +1139,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -1170,18 +1152,21 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1324,16 +1309,19 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%sct(rcv_pt,nerv,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1355,10 +1343,9 @@ end subroutine psi_sswap_vidx_vect
! Subroutine: psi_sswapdata_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector.
! Takes care of Y an encaspulated vector.
!
!
!
subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswapdata_multivect
@ -1391,9 +1378,8 @@ subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1436,7 +1422,7 @@ end subroutine psi_sswapdata_multivect
! Subroutine: psi_sswap_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
@ -1464,8 +1450,8 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -1506,22 +1492,26 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
totrcv_ = totrcv * n
totsnd_ = totsnd * n
call idx%sync()
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1561,7 +1551,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
@ -1649,7 +1639,6 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
@ -1669,16 +1658,19 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

111
base/comm/internals/psi_sswaptran.F90
Unescape Escape View File

@ -157,7 +157,8 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_sswaptranm
subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidxm
use psb_error_mod
@ -209,11 +210,11 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
goto 9999
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
@ -242,10 +243,8 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
@ -265,7 +264,6 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
@ -657,9 +655,8 @@ end subroutine psi_sswaptranv
!
!
!
subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidxv
use psb_error_mod
@ -687,12 +684,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_, n
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -743,7 +734,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -857,7 +847,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -917,7 +906,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -962,7 +950,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
@ -979,12 +966,10 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
@ -1004,7 +989,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
@ -1028,10 +1012,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
return
end subroutine psi_stranidxv
!
!
!
!
! Subroutine: psi_sswaptran_vect
@ -1131,6 +1111,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_stran_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_s_base_vect_mod
@ -1191,18 +1172,21 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1248,7 +1232,6 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1351,16 +1334,19 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%sct(snd_pt,nesd,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1386,7 +1372,7 @@ end subroutine psi_stran_vidx_vect
! Subroutine: psi_sswaptran_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector.
! Takes care of Y an encaspulated vector.
!
!
subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
@ -1461,14 +1447,13 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_sswaptran_multivect
!
!
! Subroutine: psi_stran_vidx_vect
! Subroutine: psi_stran_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
@ -1480,9 +1465,10 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_stran_vidx_multivect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_s_base_vect_mod
use psb_s_base_multivect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1542,17 +1528,20 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1593,12 +1582,11 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1686,8 +1674,6 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
@ -1707,13 +1693,18 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

112
base/comm/internals/psi_zswapdata.F90
Unescape Escape View File

@ -140,7 +140,6 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
@ -197,6 +196,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -230,7 +230,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -249,7 +248,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else
@ -310,7 +308,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -337,7 +334,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -348,7 +344,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -372,7 +367,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -407,7 +401,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
@ -438,7 +431,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -448,7 +440,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
@ -457,7 +448,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -474,11 +464,8 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -604,7 +591,8 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -618,9 +606,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
@ -644,7 +630,6 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_zswapdatav
!
!
! Subroutine: psi_zswapdataidxv
@ -700,6 +685,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -708,8 +694,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -911,7 +896,6 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_dcomplex_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
@ -1051,9 +1035,8 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1156,8 +1139,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
@ -1170,18 +1152,21 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1324,16 +1309,19 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%sct(rcv_pt,nerv,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1355,10 +1343,9 @@ end subroutine psi_zswap_vidx_vect
! Subroutine: psi_zswapdata_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector.
! Takes care of Y an encaspulated vector.
!
!
!
subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswapdata_multivect
@ -1391,9 +1378,8 @@ subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1436,7 +1422,7 @@ end subroutine psi_zswapdata_multivect
! Subroutine: psi_zswap_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
@ -1464,8 +1450,8 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -1506,22 +1492,26 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
totrcv_ = totrcv * n
totsnd_ = totsnd * n
call idx%sync()
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1561,7 +1551,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
@ -1649,7 +1639,6 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
@ -1669,16 +1658,19 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

111
base/comm/internals/psi_zswaptran.F90
Unescape Escape View File

@ -157,7 +157,8 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_zswaptranm
subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztranidxm
use psb_error_mod
@ -209,11 +210,11 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
goto 9999
endif
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_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
@ -242,10 +243,8 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
@ -265,7 +264,6 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
@ -657,9 +655,8 @@ end subroutine psi_zswaptranv
!
!
!
subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztranidxv
use psb_error_mod
@ -687,12 +684,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_, n
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -743,7 +734,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
@ -857,7 +847,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -917,7 +906,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -962,7 +950,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
@ -979,12 +966,10 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
@ -1004,7 +989,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
@ -1028,10 +1012,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
return
end subroutine psi_ztranidxv
!
!
!
!
! Subroutine: psi_zswaptran_vect
@ -1131,6 +1111,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_ztran_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_z_base_vect_mod
@ -1191,18 +1172,21 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (allocated(y%comid)) then
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1248,7 +1232,6 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1351,16 +1334,19 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%sct(snd_pt,nesd,idx,beta)
pnti = pnti + nerv + nesd + 3
end do
!
! Waited for everybody, clean up
!
y%comid = mpi_request_null
!
! Then wait
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -1386,7 +1372,7 @@ end subroutine psi_ztran_vidx_vect
! Subroutine: psi_zswaptran_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector.
! Takes care of Y an encaspulated vector.
!
!
subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
@ -1461,14 +1447,13 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_zswaptran_multivect
!
!
! Subroutine: psi_ztran_vidx_vect
! Subroutine: psi_ztran_vidx_multivect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods
! of multivectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
@ -1480,9 +1465,10 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
use psi_mod, psb_protect_name => psi_ztran_vidx_multivect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_z_base_vect_mod
use psb_z_base_multivect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1542,17 +1528,20 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
if (any(y%comid /= mpi_request_null)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives
pnti = 1
@ -1593,12 +1582,11 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
!
! Then wait
! Then wait for device
!
call y%device_wait()
if (debug) write(*,*) me,' isend'
!
! Then send
!
@ -1686,8 +1674,6 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
@ -1707,13 +1693,18 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
!
! Then wait
! Waited for com, cleanup comid
!
y%comid = mpi_request_null
!
! Then wait for device
!
if (debug) write(*,*) me,' wait'
call y%device_wait()
if (debug) write(*,*) me,' free buffer'
call y%free_buffer(info)
if (info == 0) call y%free_comid(info)
!!$ if (debug) write(*,*) me,' free buffer'
!!$ call y%free_buffer(info)
!!$ if (info == 0) call y%free_comid(info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999

Write Preview
Loading…
Cancel
Save