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

psblas-submodules:

Browse Source 
base/internals/psi_cswapdata.F90
 base/internals/psi_cswaptran.F90
 base/internals/psi_dswapdata.F90
 base/internals/psi_dswaptran.F90
 base/internals/psi_iswapdata.F90
 base/internals/psi_iswaptran.F90
 base/internals/psi_sswapdata.F90
 base/internals/psi_sswaptran.F90
 base/internals/psi_zswapdata.F90
 base/internals/psi_zswaptran.F90
 base/modules/psb_c_csr_mat_mod.f90
 base/modules/psb_d_csr_mat_mod.f90
 base/modules/psb_s_csr_mat_mod.f90
 base/modules/psb_z_csr_mat_mod.f90
 base/modules/psi_c_mod.f90
 base/modules/psi_d_mod.f90
 base/modules/psi_i_mod.f90
 base/modules/psi_s_mod.f90
 base/modules/psi_z_mod.f90

interface/implementation  mismatch fixes
psblas3-submodules
Salvatore Filippone 11 years ago
parent 7e5d678161
commit d53fd1392b
19 changed files with 9171 additions and 9016 deletions
Show Stats Download Patch File Download Diff File

299
base/internals/psi_cswapdata.F90
Unescape Escape View File

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) submodule (psi_c_mod) psi_cswapdata_mod
contains
subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswapdatam
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -150,12 +153,11 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cswapdatam end subroutine psi_cswapdatam
subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswapidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:,:), beta complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -238,7 +240,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv rvsz(proc_to_comm) = n*nerv
@ -300,7 +302,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_c_spk_,rcvbuf,rvsz,& & psb_mpi_c_spk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_c_spk_,icomm,iret) & brvidx,psb_mpi_c_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -320,14 +322,14 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -356,12 +358,12 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -370,7 +372,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
@ -386,11 +388,11 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,& call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),n*nesd,& call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -446,7 +448,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
@ -465,7 +467,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,67 +518,66 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_cswapidxm end subroutine psi_cswapidxm
! !
! !
! Subroutine: psi_cswapdatav ! Subroutine: psi_cswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswapdatav
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -641,24 +642,23 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cswapdatav end subroutine psi_cswapdatav
! !
! !
! Subroutine: psi_cswapdataidxv ! Subroutine: psi_cswapdataidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswapidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -741,7 +741,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_c_spk_,rcvbuf,rvsz,& & psb_mpi_c_spk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_c_spk_,icomm,iret) & brvidx,psb_mpi_c_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -822,14 +822,14 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -856,12 +856,12 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,& call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -870,7 +870,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,& call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),nesd,& call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -943,7 +943,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -959,7 +959,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1006,23 +1006,22 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_cswapidxv end subroutine psi_cswapidxv
! !
! !
! Subroutine: psi_cswapdata_vect ! Subroutine: psi_cswapdata_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
! !
subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswapdata_vect
use psb_c_base_vect_mod use psb_c_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1089,26 +1088,25 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cswapdata_vect end subroutine psi_cswapdata_vect
! !
! !
! Subroutine: psi_cswap_vidx_vect ! Subroutine: psi_cswap_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_cswap_vidx_vect(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswap_vidx_vect
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_desc_mod use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta complex(psb_spk_) :: beta
@ -1131,7 +1129,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1192,13 +1190,13 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1241,7 +1239,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1346,8 +1344,9 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_cswap_vidx_vect end subroutine psi_cswap_vidx_vect
end submodule psi_cswapdata_mod

310
base/internals/psi_cswaptran.F90
Unescape Escape View File

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) submodule (psi_c_mod) psi_cswaptran_mod
contains
subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptranm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -155,11 +157,10 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cswaptranm end subroutine psi_cswaptranm
subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -171,14 +172,14 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:,:), beta complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -199,10 +200,10 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -243,7 +244,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
@ -311,7 +312,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_c_spk_,& & psb_mpi_c_spk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -330,14 +331,14 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -364,12 +365,12 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,& call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -378,7 +379,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -393,11 +394,11 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),n*nerv,& call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -451,7 +452,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -468,7 +469,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,70 +517,69 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_ctranidxm end subroutine psi_ctranidxm
! !
! !
! Subroutine: psi_cswaptranv ! Subroutine: psi_cswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
! for doing the product of a sparse matrix by a vector. ! for doing the product of a sparse matrix by a vector.
! Essentially this is doing a variable all-to-all data exchange ! Essentially this is doing a variable all-to-all data exchange
! (ALLTOALLV in MPI parlance), but ! (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptranv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -644,24 +644,23 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cswaptranv end subroutine psi_cswaptranv
! !
! !
! Subroutine: psi_ctranidxv ! Subroutine: psi_ctranidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -673,14 +672,14 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -707,10 +706,10 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -751,7 +750,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -818,7 +817,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_c_spk_,& & psb_mpi_c_spk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -837,14 +836,14 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -871,12 +870,12 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,& call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -885,7 +884,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,& call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),nerv,& call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -957,7 +956,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -974,7 +973,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1024,25 +1023,24 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_ctranidxv end subroutine psi_ctranidxv
! !
! !
! !
! !
! Subroutine: psi_cswaptran_vect ! Subroutine: psi_cswaptran_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptran_vect
use psb_c_base_vect_mod use psb_c_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1109,27 +1107,26 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cswaptran_vect end subroutine psi_cswaptran_vect
! !
! !
! Subroutine: psi_ctran_vidx_vect ! Subroutine: psi_ctran_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& subroutine psi_ctran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctran_vidx_vect
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta complex(psb_spk_) :: beta
@ -1151,7 +1148,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1214,12 +1211,12 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
snd_pt = 1+pnti+nerv+psb_n_elem_send_ snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1267,7 +1264,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1372,11 +1369,10 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_ctran_vidx_vect end subroutine psi_ctran_vidx_vect
end submodule psi_cswaptran_mod

6
base/internals/psi_dswapdata.F90
Unescape Escape View File

@ -86,6 +86,7 @@
submodule (psi_d_mod) psi_dswapdata_mod submodule (psi_d_mod) psi_dswapdata_mod
contains contains
subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
@ -156,7 +157,7 @@ contains
subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx, & subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -657,7 +658,7 @@ contains
! !
subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx, & subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -1111,7 +1112,6 @@ contains
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_d_base_vect_mod use psb_d_base_vect_mod
use psi_serial_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif

5
base/internals/psi_dswaptran.F90
Unescape Escape View File

@ -160,7 +160,7 @@ contains
end subroutine psi_dswaptranm end subroutine psi_dswaptranm
subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -661,7 +661,6 @@ contains
subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -1127,7 +1126,7 @@ contains
! !
subroutine psi_dtran_vidx_vect(ictxt,icomm,flag,beta,y,idx,& subroutine psi_dtran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod

299
base/internals/psi_iswapdata.F90
Unescape Escape View File

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) submodule (psi_i_mod) psi_iswapdata_mod
contains
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdatam
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -150,12 +153,11 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_iswapdatam end subroutine psi_iswapdatam
subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswapidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:), beta integer(psb_ipk_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -238,7 +240,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv rvsz(proc_to_comm) = n*nerv
@ -300,7 +302,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_ipk_integer,rcvbuf,rvsz,& & psb_mpi_ipk_integer,rcvbuf,rvsz,&
& brvidx,psb_mpi_ipk_integer,icomm,iret) & brvidx,psb_mpi_ipk_integer,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -320,14 +322,14 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -356,12 +358,12 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -370,7 +372,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
@ -386,11 +388,11 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,& call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),n*nesd,& call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -446,7 +448,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
@ -465,7 +467,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,67 +518,66 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_iswapidxm end subroutine psi_iswapidxm
! !
! !
! Subroutine: psi_iswapdatav ! Subroutine: psi_iswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdatav
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -641,24 +642,23 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_iswapdatav end subroutine psi_iswapdatav
! !
! !
! Subroutine: psi_iswapdataidxv ! Subroutine: psi_iswapdataidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswapidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:), beta integer(psb_ipk_) :: y(:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -741,7 +741,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_ipk_integer,rcvbuf,rvsz,& & psb_mpi_ipk_integer,rcvbuf,rvsz,&
& brvidx,psb_mpi_ipk_integer,icomm,iret) & brvidx,psb_mpi_ipk_integer,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -822,14 +822,14 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -856,12 +856,12 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,& call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -870,7 +870,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,& call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),nesd,& call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -943,7 +943,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -959,7 +959,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1006,23 +1006,22 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_iswapidxv end subroutine psi_iswapidxv
! !
! !
! Subroutine: psi_iswapdata_vect ! Subroutine: psi_iswapdata_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
! !
subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdata_vect
use psb_i_base_vect_mod use psb_i_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1089,26 +1088,25 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_iswapdata_vect end subroutine psi_iswapdata_vect
! !
! !
! Subroutine: psi_iswap_vidx_vect ! Subroutine: psi_iswap_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_iswap_vidx_vect(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswap_vidx_vect
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_desc_mod use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta integer(psb_ipk_) :: beta
@ -1131,7 +1129,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1192,13 +1190,13 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1241,7 +1239,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1346,8 +1344,9 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_iswap_vidx_vect end subroutine psi_iswap_vidx_vect
end submodule psi_iswapdata_mod

310
base/internals/psi_iswaptran.F90
Unescape Escape View File

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) submodule (psi_i_mod) psi_iswaptran_mod
contains
subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptranm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -155,11 +157,10 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_iswaptranm end subroutine psi_iswaptranm
subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -171,14 +172,14 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:), beta integer(psb_ipk_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -199,10 +200,10 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -243,7 +244,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
@ -311,7 +312,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_ipk_integer,& & psb_mpi_ipk_integer,&
& sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -330,14 +331,14 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -364,12 +365,12 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,& call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -378,7 +379,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -393,11 +394,11 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),n*nerv,& call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -451,7 +452,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -468,7 +469,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,70 +517,69 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_itranidxm end subroutine psi_itranidxm
! !
! !
! Subroutine: psi_iswaptranv ! Subroutine: psi_iswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
! for doing the product of a sparse matrix by a vector. ! for doing the product of a sparse matrix by a vector.
! Essentially this is doing a variable all-to-all data exchange ! Essentially this is doing a variable all-to-all data exchange
! (ALLTOALLV in MPI parlance), but ! (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptranv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -644,24 +644,23 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_iswaptranv end subroutine psi_iswaptranv
! !
! !
! Subroutine: psi_itranidxv ! Subroutine: psi_itranidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -673,14 +672,14 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:), beta integer(psb_ipk_) :: y(:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -707,10 +706,10 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -751,7 +750,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -818,7 +817,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_ipk_integer,& & psb_mpi_ipk_integer,&
& sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -837,14 +836,14 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -871,12 +870,12 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,& call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -885,7 +884,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,& call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),nerv,& call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -957,7 +956,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -974,7 +973,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1024,25 +1023,24 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_itranidxv end subroutine psi_itranidxv
! !
! !
! !
! !
! Subroutine: psi_iswaptran_vect ! Subroutine: psi_iswaptran_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptran_vect
use psb_i_base_vect_mod use psb_i_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1109,27 +1107,26 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_iswaptran_vect end subroutine psi_iswaptran_vect
! !
! !
! Subroutine: psi_itran_vidx_vect ! Subroutine: psi_itran_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& subroutine psi_itran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itran_vidx_vect
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta integer(psb_ipk_) :: beta
@ -1151,7 +1148,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1214,12 +1211,12 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
snd_pt = 1+pnti+nerv+psb_n_elem_send_ snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1267,7 +1264,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1372,11 +1369,10 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_itran_vidx_vect end subroutine psi_itran_vidx_vect
end submodule psi_iswaptran_mod

299
base/internals/psi_sswapdata.F90
Unescape Escape View File

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) submodule (psi_s_mod) psi_sswapdata_mod
contains
subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswapdatam
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -150,12 +153,11 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_sswapdatam end subroutine psi_sswapdatam
subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswapidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:,:), beta real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -238,7 +240,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv rvsz(proc_to_comm) = n*nerv
@ -300,7 +302,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_r_spk_,rcvbuf,rvsz,& & psb_mpi_r_spk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_r_spk_,icomm,iret) & brvidx,psb_mpi_r_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -320,14 +322,14 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -356,12 +358,12 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -370,7 +372,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
@ -386,11 +388,11 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,& call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),n*nesd,& call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -446,7 +448,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
@ -465,7 +467,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,67 +518,66 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_sswapidxm end subroutine psi_sswapidxm
! !
! !
! Subroutine: psi_sswapdatav ! Subroutine: psi_sswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswapdatav
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -641,24 +642,23 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_sswapdatav end subroutine psi_sswapdatav
! !
! !
! Subroutine: psi_sswapdataidxv ! Subroutine: psi_sswapdataidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswapidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -741,7 +741,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_r_spk_,rcvbuf,rvsz,& & psb_mpi_r_spk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_r_spk_,icomm,iret) & brvidx,psb_mpi_r_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -822,14 +822,14 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -856,12 +856,12 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,& call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -870,7 +870,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,& call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),nesd,& call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -943,7 +943,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -959,7 +959,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1006,23 +1006,22 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_sswapidxv end subroutine psi_sswapidxv
! !
! !
! Subroutine: psi_sswapdata_vect ! Subroutine: psi_sswapdata_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
! !
subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswapdata_vect
use psb_s_base_vect_mod use psb_s_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1089,26 +1088,25 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_sswapdata_vect end subroutine psi_sswapdata_vect
! !
! !
! Subroutine: psi_sswap_vidx_vect ! Subroutine: psi_sswap_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_sswap_vidx_vect(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswap_vidx_vect
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_desc_mod use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta real(psb_spk_) :: beta
@ -1131,7 +1129,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1192,13 +1190,13 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1241,7 +1239,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1346,8 +1344,9 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_sswap_vidx_vect end subroutine psi_sswap_vidx_vect
end submodule psi_sswapdata_mod

310
base/internals/psi_sswaptran.F90
Unescape Escape View File

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) submodule (psi_s_mod) psi_sswaptran_mod
contains
subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptranm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -155,11 +157,10 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_sswaptranm end subroutine psi_sswaptranm
subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -171,14 +172,14 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:,:), beta real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -199,10 +200,10 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -243,7 +244,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
@ -311,7 +312,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_r_spk_,& & psb_mpi_r_spk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -330,14 +331,14 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -364,12 +365,12 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,& call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -378,7 +379,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -393,11 +394,11 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),n*nerv,& call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -451,7 +452,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -468,7 +469,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,70 +517,69 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_stranidxm end subroutine psi_stranidxm
! !
! !
! Subroutine: psi_sswaptranv ! Subroutine: psi_sswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
! for doing the product of a sparse matrix by a vector. ! for doing the product of a sparse matrix by a vector.
! Essentially this is doing a variable all-to-all data exchange ! Essentially this is doing a variable all-to-all data exchange
! (ALLTOALLV in MPI parlance), but ! (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptranv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -644,24 +644,23 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_sswaptranv end subroutine psi_sswaptranv
! !
! !
! Subroutine: psi_stranidxv ! Subroutine: psi_stranidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -673,14 +672,14 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -707,10 +706,10 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -751,7 +750,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -818,7 +817,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_r_spk_,& & psb_mpi_r_spk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -837,14 +836,14 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -871,12 +870,12 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,& call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -885,7 +884,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,& call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),nerv,& call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -957,7 +956,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -974,7 +973,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1024,25 +1023,24 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_stranidxv end subroutine psi_stranidxv
! !
! !
! !
! !
! Subroutine: psi_sswaptran_vect ! Subroutine: psi_sswaptran_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptran_vect
use psb_s_base_vect_mod use psb_s_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1109,27 +1107,26 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_sswaptran_vect end subroutine psi_sswaptran_vect
! !
! !
! Subroutine: psi_stran_vidx_vect ! Subroutine: psi_stran_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& subroutine psi_stran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stran_vidx_vect
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta real(psb_spk_) :: beta
@ -1151,7 +1148,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1214,12 +1211,12 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
snd_pt = 1+pnti+nerv+psb_n_elem_send_ snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1267,7 +1264,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1372,11 +1369,10 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_stran_vidx_vect end subroutine psi_stran_vidx_vect
end submodule psi_sswaptran_mod

299
base/internals/psi_zswapdata.F90
Unescape Escape View File

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) submodule (psi_z_mod) psi_zswapdata_mod
contains
subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswapdatam
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -150,12 +153,11 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_zswapdatam end subroutine psi_zswapdatam
subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswapidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -238,7 +240,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv rvsz(proc_to_comm) = n*nerv
@ -300,7 +302,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_c_dpk_,rcvbuf,rvsz,& & psb_mpi_c_dpk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_c_dpk_,icomm,iret) & brvidx,psb_mpi_c_dpk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -320,14 +322,14 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -356,12 +358,12 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -370,7 +372,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
@ -386,11 +388,11 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,& call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),n*nesd,& call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -446,7 +448,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
@ -465,7 +467,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,67 +518,66 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_zswapidxm end subroutine psi_zswapidxm
! !
! !
! Subroutine: psi_zswapdatav ! Subroutine: psi_zswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswapdatav
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -641,24 +642,23 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_zswapdatav end subroutine psi_zswapdatav
! !
! !
! Subroutine: psi_zswapdataidxv ! Subroutine: psi_zswapdataidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswapidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -741,7 +741,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,& call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_c_dpk_,rcvbuf,rvsz,& & psb_mpi_c_dpk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_c_dpk_,icomm,iret) & brvidx,psb_mpi_c_dpk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -822,14 +822,14 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -856,12 +856,12 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,& call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret) & p2ptag, iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -870,7 +870,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,& call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(sndbuf(snd_pt),nesd,& call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -943,7 +943,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,& if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -959,7 +959,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,& if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1006,23 +1006,22 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_zswapidxv end subroutine psi_zswapidxv
! !
! !
! Subroutine: psi_zswapdata_vect ! Subroutine: psi_zswapdata_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
! !
subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswapdata_vect
use psb_z_base_vect_mod use psb_z_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1089,26 +1088,25 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_zswapdata_vect end subroutine psi_zswapdata_vect
! !
! !
! Subroutine: psi_zswap_vidx_vect ! Subroutine: psi_zswap_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & subroutine psi_zswap_vidx_vect(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswap_vidx_vect
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_desc_mod use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta
@ -1131,7 +1129,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1192,13 +1190,13 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1241,7 +1239,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1346,8 +1344,9 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_zswap_vidx_vect end subroutine psi_zswap_vidx_vect
end submodule psi_zswapdata_mod

310
base/internals/psi_zswaptran.F90
Unescape Escape View File

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) submodule (psi_z_mod) psi_zswaptran_mod
contains
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswaptranm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -155,11 +157,10 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_zswaptranm end subroutine psi_zswaptranm
subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztranidxm
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -171,14 +172,14 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -199,10 +200,10 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -243,7 +244,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
@ -311,7 +312,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_c_dpk_,& & psb_mpi_c_dpk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -330,14 +331,14 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -364,12 +365,12 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,& call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -378,7 +379,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -393,11 +394,11 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),n*nerv,& call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret) & p2ptag,iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -451,7 +452,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -468,7 +469,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd snd_pt = snd_pt + n*nesd
@ -516,70 +517,69 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_ztranidxm end subroutine psi_ztranidxm
! !
! !
! Subroutine: psi_zswaptranv ! Subroutine: psi_zswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
! for doing the product of a sparse matrix by a vector. ! for doing the product of a sparse matrix by a vector.
! Essentially this is doing a variable all-to-all data exchange ! Essentially this is doing a variable all-to-all data exchange
! (ALLTOALLV in MPI parlance), but ! (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure ! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer ! In all these subroutines X may be: I Integer
! S real(psb_spk_) ! S real(psb_spk_)
! D real(psb_dpk_) ! D real(psb_dpk_)
! C complex(psb_spk_) ! C complex(psb_spk_)
! Z complex(psb_dpk_) ! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify ! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation. ! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the ! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section ! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1. ! is scattered in the owned indices, and BETA=1.
! !
! Arguments: ! Arguments:
! flag - integer Choose the algorithm for data exchange: ! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0 ! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0 ! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0 ! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in ! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs ! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv ! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send ! and mpi_send
! if (swap_send): use psb_snd (but need another ! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete) ! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a ! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send) ! previous call with swap_send)
! !
! !
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
! data - integer which list is to be used to exchange data ! data - integer which list is to be used to exchange data
! default psb_comm_halo_ ! default psb_comm_halo_
! psb_comm_halo_ use halo_index ! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index ! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index ! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx ! psb_comm_mov_ use ovr_mst_idx
! !
! !
subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswaptranv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -644,24 +644,23 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_zswaptranv end subroutine psi_zswaptranv
! !
! !
! Subroutine: psi_ztranidxv ! Subroutine: psi_ztranidxv
! Does the data exchange among processes. ! Does the data exchange among processes.
! !
! The real workhorse: the outer routines will only choose the index list ! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztranidxv
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -673,14 +672,14 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
@ -707,10 +706,10 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -751,7 +750,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv rvsz(proc_to_comm) = nerv
@ -818,7 +817,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! swap elements using mpi_alltoallv ! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,& call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_c_dpk_,& & psb_mpi_c_dpk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,iicomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
ierr(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
@ -837,14 +836,14 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
if (nesd /= nerv) then if (nesd /= nerv) then
@ -871,12 +870,12 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,& call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret) & p2ptag,iicomm,rvhd(i),iret)
end if end if
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -885,7 +884,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret) if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,& call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
else else
call mpi_send(rcvbuf(rcv_pt),nerv,& call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,iret) & p2ptag, iicomm,iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -957,7 +956,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,& if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -974,7 +973,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
proc_to_comm = idx(pnti+psb_proc_id_) proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_) nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_) nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,& if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd snd_pt = snd_pt + nesd
@ -1024,25 +1023,24 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_ztranidxv end subroutine psi_ztranidxv
! !
! !
! !
! !
! Subroutine: psi_zswaptran_vect ! Subroutine: psi_zswaptran_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. ! Takes care of Y an exanspulated vector.
! !
! !
subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswaptran_vect
use psb_z_base_vect_mod use psb_z_base_vect_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
@ -1109,27 +1107,26 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_zswaptran_vect end subroutine psi_zswaptran_vect
! !
! !
! Subroutine: psi_ztran_vidx_vect ! Subroutine: psi_ztran_vidx_vect
! Data exchange among processes. ! Data exchange among processes.
! !
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors. ! of vectors.
! !
! The real workhorse: the outer routine will only choose the index list ! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange. ! this one takes the index list and does the actual exchange.
! !
! !
! !
subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& subroutine psi_ztran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztran_vidx_vect
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta
@ -1151,7 +1148,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals ! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,& integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:) integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,& integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt iictxt = ictxt
icomm = iicomm iicomm = icomm
call psb_info(ictxt,me,np) call psb_info(iictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
@ -1214,12 +1211,12 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
snd_pt = 1+pnti+nerv+psb_n_elem_send_ snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, iicomm,y%comid(i,2),iret)
end if end if
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1267,7 +1264,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,iicomm,y%comid(i,1),iret)
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
@ -1372,11 +1369,10 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(iictxt,err_act)
return return
end subroutine psi_ztran_vidx_vect end subroutine psi_ztran_vidx_vect
end submodule psi_zswaptran_mod

48
base/modules/psb_c_csr_mat_mod.f90
Unescape Escape View File

@ -98,12 +98,17 @@ module psb_c_csr_mat_mod
procedure, pass(a) :: print => psb_c_csr_print procedure, pass(a) :: print => psb_c_csr_print
procedure, pass(a) :: free => c_csr_free procedure, pass(a) :: free => c_csr_free
procedure, pass(a) :: mold => psb_c_csr_mold procedure, pass(a) :: mold => psb_c_csr_mold
procedure, pass(a) :: get_irpp => c_csr_get_irpp
procedure, pass(a) :: get_jap => c_csr_get_jap
procedure, pass(a) :: get_valp => c_csr_get_valp
end type psb_c_csr_sparse_mat end type psb_c_csr_sparse_mat
private :: c_csr_get_nzeros, c_csr_free, c_csr_get_fmt, & private :: c_csr_get_nzeros, c_csr_free, c_csr_get_fmt, &
& c_csr_get_size, c_csr_sizeof, c_csr_get_nz_row, & & c_csr_get_size, c_csr_sizeof, c_csr_get_nz_row, &
& c_csr_is_by_rows & c_csr_is_by_rows, c_csr_get_irpp, c_csr_get_jap, &
& c_csr_get_valp
!> \memberof psb_c_csr_sparse_mat !> \memberof psb_c_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_reallocate_nz !| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
end subroutine c_csr_free end subroutine c_csr_free
function c_csr_get_irpp(a) result(res)
implicit none
class(psb_c_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%irp)) then
res => a%irp
else
res => null()
end if
end function c_csr_get_irpp
function c_csr_get_jap(a) result(res)
implicit none
class(psb_c_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%ja)) then
res => a%ja
else
res => null()
end if
end function c_csr_get_jap
function c_csr_get_valp(a) result(res)
implicit none
class(psb_c_csr_sparse_mat), intent(in), target :: a
complex(psb_spk_), pointer :: res(:)
if (allocated(a%val)) then
res => a%val
else
res => null()
end if
end function c_csr_get_valp
end module psb_c_csr_mat_mod end module psb_c_csr_mat_mod

48
base/modules/psb_d_csr_mat_mod.f90
Unescape Escape View File

@ -98,12 +98,17 @@ module psb_d_csr_mat_mod
procedure, pass(a) :: print => psb_d_csr_print procedure, pass(a) :: print => psb_d_csr_print
procedure, pass(a) :: free => d_csr_free procedure, pass(a) :: free => d_csr_free
procedure, pass(a) :: mold => psb_d_csr_mold procedure, pass(a) :: mold => psb_d_csr_mold
procedure, pass(a) :: get_irpp => d_csr_get_irpp
procedure, pass(a) :: get_jap => d_csr_get_jap
procedure, pass(a) :: get_valp => d_csr_get_valp
end type psb_d_csr_sparse_mat end type psb_d_csr_sparse_mat
private :: d_csr_get_nzeros, d_csr_free, d_csr_get_fmt, & private :: d_csr_get_nzeros, d_csr_free, d_csr_get_fmt, &
& d_csr_get_size, d_csr_sizeof, d_csr_get_nz_row, & & d_csr_get_size, d_csr_sizeof, d_csr_get_nz_row, &
& d_csr_is_by_rows & d_csr_is_by_rows, d_csr_get_irpp, d_csr_get_jap, &
& d_csr_get_valp
!> \memberof psb_d_csr_sparse_mat !> \memberof psb_d_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_reallocate_nz !| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
end subroutine d_csr_free end subroutine d_csr_free
function d_csr_get_irpp(a) result(res)
implicit none
class(psb_d_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%irp)) then
res => a%irp
else
res => null()
end if
end function d_csr_get_irpp
function d_csr_get_jap(a) result(res)
implicit none
class(psb_d_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%ja)) then
res => a%ja
else
res => null()
end if
end function d_csr_get_jap
function d_csr_get_valp(a) result(res)
implicit none
class(psb_d_csr_sparse_mat), intent(in), target :: a
real(psb_dpk_), pointer :: res(:)
if (allocated(a%val)) then
res => a%val
else
res => null()
end if
end function d_csr_get_valp
end module psb_d_csr_mat_mod end module psb_d_csr_mat_mod

48
base/modules/psb_s_csr_mat_mod.f90
Unescape Escape View File

@ -98,12 +98,17 @@ module psb_s_csr_mat_mod
procedure, pass(a) :: print => psb_s_csr_print procedure, pass(a) :: print => psb_s_csr_print
procedure, pass(a) :: free => s_csr_free procedure, pass(a) :: free => s_csr_free
procedure, pass(a) :: mold => psb_s_csr_mold procedure, pass(a) :: mold => psb_s_csr_mold
procedure, pass(a) :: get_irpp => s_csr_get_irpp
procedure, pass(a) :: get_jap => s_csr_get_jap
procedure, pass(a) :: get_valp => s_csr_get_valp
end type psb_s_csr_sparse_mat end type psb_s_csr_sparse_mat
private :: s_csr_get_nzeros, s_csr_free, s_csr_get_fmt, & private :: s_csr_get_nzeros, s_csr_free, s_csr_get_fmt, &
& s_csr_get_size, s_csr_sizeof, s_csr_get_nz_row, & & s_csr_get_size, s_csr_sizeof, s_csr_get_nz_row, &
& s_csr_is_by_rows & s_csr_is_by_rows, s_csr_get_irpp, s_csr_get_jap, &
& s_csr_get_valp
!> \memberof psb_s_csr_sparse_mat !> \memberof psb_s_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_reallocate_nz !| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
end subroutine s_csr_free end subroutine s_csr_free
function s_csr_get_irpp(a) result(res)
implicit none
class(psb_s_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%irp)) then
res => a%irp
else
res => null()
end if
end function s_csr_get_irpp
function s_csr_get_jap(a) result(res)
implicit none
class(psb_s_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%ja)) then
res => a%ja
else
res => null()
end if
end function s_csr_get_jap
function s_csr_get_valp(a) result(res)
implicit none
class(psb_s_csr_sparse_mat), intent(in), target :: a
real(psb_spk_), pointer :: res(:)
if (allocated(a%val)) then
res => a%val
else
res => null()
end if
end function s_csr_get_valp
end module psb_s_csr_mat_mod end module psb_s_csr_mat_mod

48
base/modules/psb_z_csr_mat_mod.f90
Unescape Escape View File

@ -98,12 +98,17 @@ module psb_z_csr_mat_mod
procedure, pass(a) :: print => psb_z_csr_print procedure, pass(a) :: print => psb_z_csr_print
procedure, pass(a) :: free => z_csr_free procedure, pass(a) :: free => z_csr_free
procedure, pass(a) :: mold => psb_z_csr_mold procedure, pass(a) :: mold => psb_z_csr_mold
procedure, pass(a) :: get_irpp => z_csr_get_irpp
procedure, pass(a) :: get_jap => z_csr_get_jap
procedure, pass(a) :: get_valp => z_csr_get_valp
end type psb_z_csr_sparse_mat end type psb_z_csr_sparse_mat
private :: z_csr_get_nzeros, z_csr_free, z_csr_get_fmt, & private :: z_csr_get_nzeros, z_csr_free, z_csr_get_fmt, &
& z_csr_get_size, z_csr_sizeof, z_csr_get_nz_row, & & z_csr_get_size, z_csr_sizeof, z_csr_get_nz_row, &
& z_csr_is_by_rows & z_csr_is_by_rows, z_csr_get_irpp, z_csr_get_jap, &
& z_csr_get_valp
!> \memberof psb_z_csr_sparse_mat !> \memberof psb_z_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_reallocate_nz !| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
end subroutine z_csr_free end subroutine z_csr_free
function z_csr_get_irpp(a) result(res)
implicit none
class(psb_z_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%irp)) then
res => a%irp
else
res => null()
end if
end function z_csr_get_irpp
function z_csr_get_jap(a) result(res)
implicit none
class(psb_z_csr_sparse_mat), intent(in), target :: a
integer(psb_ipk_), pointer :: res(:)
if (allocated(a%ja)) then
res => a%ja
else
res => null()
end if
end function z_csr_get_jap
function z_csr_get_valp(a) result(res)
implicit none
class(psb_z_csr_sparse_mat), intent(in), target :: a
complex(psb_dpk_), pointer :: res(:)
if (allocated(a%val)) then
res => a%val
else
res => null()
end if
end function z_csr_get_valp
end module psb_z_csr_mat_mod end module psb_z_csr_mat_mod

8
base/modules/psi_c_mod.f90
Unescape Escape View File

@ -76,9 +76,9 @@ module psi_c_mod
complex(psb_spk_),target :: work(:) complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_cswapidxv end subroutine psi_cswapidxv
module subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_cswap_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta complex(psb_spk_) :: beta
@ -131,9 +131,9 @@ module psi_c_mod
complex(psb_spk_),target :: work(:) complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ctranidxv end subroutine psi_ctranidxv
module subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_ctran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta complex(psb_spk_) :: beta

8
base/modules/psi_d_mod.f90
Unescape Escape View File

@ -76,9 +76,9 @@ module psi_d_mod
real(psb_dpk_),target :: work(:) real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv end subroutine psi_dswapidxv
module subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_dswap_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta real(psb_dpk_) :: beta
@ -131,9 +131,9 @@ module psi_d_mod
real(psb_dpk_),target :: work(:) real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxv end subroutine psi_dtranidxv
module subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_dtran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta real(psb_dpk_) :: beta

8
base/modules/psi_i_mod.f90
Unescape Escape View File

@ -218,9 +218,9 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:) integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_iswapidxv end subroutine psi_iswapidxv
module subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_iswap_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta integer(psb_ipk_) :: beta
@ -273,9 +273,9 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:) integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_itranidxv end subroutine psi_itranidxv
module subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_itran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta integer(psb_ipk_) :: beta

8
base/modules/psi_s_mod.f90
Unescape Escape View File

@ -76,9 +76,9 @@ module psi_s_mod
real(psb_spk_),target :: work(:) real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_sswapidxv end subroutine psi_sswapidxv
module subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_sswap_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta real(psb_spk_) :: beta
@ -131,9 +131,9 @@ module psi_s_mod
real(psb_spk_),target :: work(:) real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_stranidxv end subroutine psi_stranidxv
module subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_stran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta real(psb_spk_) :: beta

8
base/modules/psi_z_mod.f90
Unescape Escape View File

@ -76,9 +76,9 @@ module psi_z_mod
complex(psb_dpk_),target :: work(:) complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_zswapidxv end subroutine psi_zswapidxv
module subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_zswap_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta
@ -131,9 +131,9 @@ module psi_z_mod
complex(psb_dpk_),target :: work(:) complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidxv end subroutine psi_ztranidxv
module subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& module subroutine psi_ztran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta

Write Preview
Loading…
Cancel
Save