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 10 years ago
parent 7e5d678161
commit d53fd1392b
19 changed files with 9171 additions and 9016 deletions
Show Stats Download Patch File Download Diff File

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

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -152,10 +155,9 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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)
use psi_mod, psb_protect_name => psi_cswapidxm
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h'
#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
complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_complex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
@ -386,11 +388,11 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +518,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_cswapidxm
@ -576,7 +578,6 @@ end subroutine psi_cswapidxm
!
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_desc_mod
use psb_penv_mod
@ -655,10 +656,9 @@ end subroutine psi_cswapdatav
!
!
!
subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswapidxv
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
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)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
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
p2ptag = psb_complex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1006,7 +1006,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_cswapidxv
@ -1022,7 +1022,6 @@ end subroutine psi_cswapidxv
!
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_error_mod
use psb_desc_mod
@ -1105,10 +1104,9 @@ end subroutine psi_cswapdata_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_cswap_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_complex_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_cswap_vidx_vect
end submodule psi_cswapdata_mod

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

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -157,9 +159,8 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_cswaptranm
subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ctranidxm(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_desc_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'
#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
complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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
@ -311,7 +312,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_complex_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 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
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +517,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_ctranidxm
@ -579,7 +580,6 @@ end subroutine psi_ctranidxm
!
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_desc_mod
use psb_penv_mod
@ -659,9 +659,8 @@ end subroutine psi_cswaptranv
!
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_desc_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'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
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)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_complex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1024,7 +1023,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_ctranidxv
@ -1042,7 +1041,6 @@ end subroutine psi_ctranidxv
!
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_error_mod
use psb_desc_mod
@ -1126,10 +1124,9 @@ end subroutine psi_cswaptran_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_ctran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
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
contains
subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod
@ -156,7 +157,7 @@ contains
subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -657,7 +658,7 @@ contains
!
subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1111,7 +1112,6 @@ contains
use psb_desc_mod
use psb_penv_mod
use psb_d_base_vect_mod
use psi_serial_mod
#ifdef MPI_MOD
use mpi
#endif

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

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

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

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -152,10 +155,9 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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)
use psi_mod, psb_protect_name => psi_iswapidxm
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h'
#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_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_int_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
@ -386,11 +388,11 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +518,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_iswapidxm
@ -576,7 +578,6 @@ end subroutine psi_iswapidxm
!
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_desc_mod
use psb_penv_mod
@ -655,10 +656,9 @@ end subroutine psi_iswapdatav
!
!
!
subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswapidxv
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#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_) :: y(:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
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)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
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
p2ptag = psb_int_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1006,7 +1006,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_iswapidxv
@ -1022,7 +1022,6 @@ end subroutine psi_iswapidxv
!
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_error_mod
use psb_desc_mod
@ -1105,10 +1104,9 @@ end subroutine psi_iswapdata_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_iswap_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_int_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_iswap_vidx_vect
end submodule psi_iswapdata_mod

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

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -157,9 +159,8 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_iswaptranm
subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_itranidxm(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_desc_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'
#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_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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
@ -311,7 +312,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 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
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +517,7 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_itranidxm
@ -579,7 +580,6 @@ end subroutine psi_itranidxm
!
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_desc_mod
use psb_penv_mod
@ -659,9 +659,8 @@ end subroutine psi_iswaptranv
!
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_desc_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'
#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_) :: y(:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
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)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1024,7 +1023,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_itranidxv
@ -1042,7 +1041,6 @@ end subroutine psi_itranidxv
!
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_error_mod
use psb_desc_mod
@ -1126,10 +1124,9 @@ end subroutine psi_iswaptran_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_itran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_itran_vidx_vect
end submodule psi_iswaptran_mod

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

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -152,10 +155,9 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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)
use psi_mod, psb_protect_name => psi_sswapidxm
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h'
#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
real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_real_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
@ -386,11 +388,11 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +518,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_sswapidxm
@ -576,7 +578,6 @@ end subroutine psi_sswapidxm
!
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_desc_mod
use psb_penv_mod
@ -655,10 +656,9 @@ end subroutine psi_sswapdatav
!
!
!
subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswapidxv
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
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)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
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
p2ptag = psb_real_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1006,7 +1006,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_sswapidxv
@ -1022,7 +1022,6 @@ end subroutine psi_sswapidxv
!
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_error_mod
use psb_desc_mod
@ -1105,10 +1104,9 @@ end subroutine psi_sswapdata_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_sswap_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_real_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_sswap_vidx_vect
end submodule psi_sswapdata_mod

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

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -157,9 +159,8 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_sswaptranm
subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_stranidxm(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_desc_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'
#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
real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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
@ -311,7 +312,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_real_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 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
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +517,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_stranidxm
@ -579,7 +580,6 @@ end subroutine psi_stranidxm
!
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_desc_mod
use psb_penv_mod
@ -659,9 +659,8 @@ end subroutine psi_sswaptranv
!
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_desc_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'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
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)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_real_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1024,7 +1023,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_stranidxv
@ -1042,7 +1041,6 @@ end subroutine psi_stranidxv
!
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_error_mod
use psb_desc_mod
@ -1126,10 +1124,9 @@ end subroutine psi_sswaptran_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_stran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_stran_vidx_vect
end submodule psi_sswaptran_mod

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

@ -83,9 +83,12 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -152,10 +155,9 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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)
use psi_mod, psb_protect_name => psi_zswapidxm
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -167,14 +169,14 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
include 'mpif.h'
#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
complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -195,9 +197,9 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
@ -386,11 +388,11 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +518,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_zswapidxm
@ -576,7 +578,6 @@ end subroutine psi_zswapidxm
!
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_desc_mod
use psb_penv_mod
@ -655,10 +656,9 @@ end subroutine psi_zswapdatav
!
!
!
subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswapidxv
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -670,14 +670,14 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -698,9 +698,9 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
@ -803,7 +803,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& 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
ierr(1) = iret
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_)
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)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
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)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
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
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -886,11 +886,11 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1006,7 +1006,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_zswapidxv
@ -1022,7 +1022,6 @@ end subroutine psi_zswapidxv
!
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_error_mod
use psb_desc_mod
@ -1105,10 +1104,9 @@ end subroutine psi_zswapdata_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_zswap_vidx_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
@ -1122,7 +1120,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1146,10 +1144,10 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_zswap_vidx_vect
end submodule psi_zswapdata_mod

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

@ -87,9 +87,11 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
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_desc_mod
use psb_penv_mod
@ -157,9 +159,8 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end subroutine psi_zswaptranm
subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxm(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_desc_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'
#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
complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
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
@ -311,7 +312,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
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)
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)
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)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 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
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -516,7 +517,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_ztranidxm
@ -579,7 +580,6 @@ end subroutine psi_ztranidxm
!
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_desc_mod
use psb_penv_mod
@ -659,9 +659,8 @@ end subroutine psi_zswaptranv
!
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_desc_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'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& 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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
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
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& 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
ierr(1) = iret
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_)
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)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
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)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) 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_)
nerv = idx(pnti+psb_n_elem_recv_)
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
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
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
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -900,11 +899,11 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
end if
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
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_)
nerv = idx(pnti+psb_n_elem_recv_)
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)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1024,7 +1023,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_ztranidxv
@ -1042,7 +1041,6 @@ end subroutine psi_ztranidxv
!
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_error_mod
use psb_desc_mod
@ -1126,10 +1124,9 @@ end subroutine psi_zswaptran_vect
!
!
!
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)
use psi_mod, psb_protect_name => psi_ztran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1142,7 +1139,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
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
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1166,10 +1163,10 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
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_
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 (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
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
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
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)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
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) :: free => c_csr_free
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
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_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
!| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
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

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) :: free => d_csr_free
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
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_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
!| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
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

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) :: free => s_csr_free
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
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_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
!| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
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

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) :: free => z_csr_free
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
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_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
!| \see psb_base_mat_mod::psb_base_reallocate_nz
@ -580,5 +585,44 @@ contains
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

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

@ -76,9 +76,9 @@ module psi_c_mod
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
@ -131,9 +131,9 @@ module psi_c_mod
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
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(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
@ -131,9 +131,9 @@ module psi_d_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
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_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
@ -273,9 +273,9 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
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(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
@ -131,9 +131,9 @@ module psi_s_mod
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
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(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
@ -131,9 +131,9 @@ module psi_z_mod
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
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)
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta

Write Preview
Loading…
Cancel
Save