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

psblas:

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_base_vect_mod.f90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_z_base_vect_mod.f90

Set up full support for multivectors, step 2: make HALO work.
psblas-3.4-maint
Salvatore Filippone 10 years ago
parent 27e4cab518
commit da035aae38
15 changed files with 325 additions and 280 deletions
Show Stats Download Patch File Download Diff File

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

@ -1495,7 +1495,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -1525,20 +1525,22 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' Gather ' if (debug) write(*,*) me,' Gather '
@ -1546,13 +1548,15 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,snd_pt,nesd,idx)
idx_pt = snd_pt rcv_pt = rcv_pt + n*nerv
call y%gth(idx_pt,nesd,idx) snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1567,18 +1571,16 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1589,7 +1591,8 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1609,14 +1612,13 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nesd>0) then if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1642,26 +1644,29 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1) & y%combuf(rcv_pt:rcv_pt+n*nerv-1)
call y%sct(rcv_pt,nerv,idx,beta) call y%sct(idx_pt,rcv_pt,nerv,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1525,7 +1525,8 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0
@ -1555,21 +1556,22 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
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),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),n*nesd,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1578,16 +1580,15 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,rcv_pt,nerv,idx)
rcv_pt = rcv_pt + n*nerv
idx_pt = rcv_pt snd_pt = snd_pt + n*nesd
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1603,18 +1604,17 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_c_spk_,prcid(i),& & psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1625,7 +1625,8 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1645,14 +1646,13 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_complex_swap_tag p2ptag = psb_complex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nerv>0) then if (nerv>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1678,26 +1678,30 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1) & y%combuf(snd_pt:snd_pt+n*nesd-1)
call y%sct(snd_pt,nesd,idx,beta) call y%sct(idx_pt,snd_pt,nesd,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1495,7 +1495,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -1525,20 +1525,22 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_double_swap_tag p2ptag = psb_double_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_r_dpk_,prcid(i),& & psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' Gather ' if (debug) write(*,*) me,' Gather '
@ -1546,13 +1548,15 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,snd_pt,nesd,idx)
idx_pt = snd_pt rcv_pt = rcv_pt + n*nerv
call y%gth(idx_pt,nesd,idx) snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1567,18 +1571,16 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_double_swap_tag p2ptag = psb_double_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),n*nesd,&
& psb_mpi_r_dpk_,prcid(i),& & psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1589,7 +1591,8 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1609,14 +1612,13 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_double_swap_tag p2ptag = psb_double_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nesd>0) then if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1642,26 +1644,29 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1) & y%combuf(rcv_pt:rcv_pt+n*nerv-1)
call y%sct(rcv_pt,nerv,idx,beta) call y%sct(idx_pt,rcv_pt,nerv,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1525,7 +1525,8 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0
@ -1555,21 +1556,22 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_double_swap_tag p2ptag = psb_double_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
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),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),n*nesd,&
& psb_mpi_r_dpk_,prcid(i),& & psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1578,16 +1580,15 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,rcv_pt,nerv,idx)
rcv_pt = rcv_pt + n*nerv
idx_pt = rcv_pt snd_pt = snd_pt + n*nesd
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1603,18 +1604,17 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_double_swap_tag p2ptag = psb_double_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_r_dpk_,prcid(i),& & psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1625,7 +1625,8 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1645,14 +1646,13 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_double_swap_tag p2ptag = psb_double_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nerv>0) then if (nerv>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1678,26 +1678,30 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1) & y%combuf(snd_pt:snd_pt+n*nesd-1)
call y%sct(snd_pt,nesd,idx,beta) call y%sct(idx_pt,snd_pt,nesd,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1495,7 +1495,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -1525,20 +1525,22 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' Gather ' if (debug) write(*,*) me,' Gather '
@ -1546,13 +1548,15 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,snd_pt,nesd,idx)
idx_pt = snd_pt rcv_pt = rcv_pt + n*nerv
call y%gth(idx_pt,nesd,idx) snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1567,18 +1571,16 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1589,7 +1591,8 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1609,14 +1612,13 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nesd>0) then if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1642,26 +1644,29 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1) & y%combuf(rcv_pt:rcv_pt+n*nerv-1)
call y%sct(rcv_pt,nerv,idx,beta) call y%sct(idx_pt,rcv_pt,nerv,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1525,7 +1525,8 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0
@ -1555,21 +1556,22 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
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),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),n*nesd,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1578,16 +1580,15 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,rcv_pt,nerv,idx)
rcv_pt = rcv_pt + n*nerv
idx_pt = rcv_pt snd_pt = snd_pt + n*nesd
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1603,18 +1604,17 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_ipk_integer,prcid(i),& & psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1625,7 +1625,8 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1645,14 +1646,13 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_int_swap_tag p2ptag = psb_int_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nerv>0) then if (nerv>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1678,26 +1678,30 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1) & y%combuf(snd_pt:snd_pt+n*nesd-1)
call y%sct(snd_pt,nesd,idx,beta) call y%sct(idx_pt,snd_pt,nesd,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1495,7 +1495,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -1525,20 +1525,22 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' Gather ' if (debug) write(*,*) me,' Gather '
@ -1546,13 +1548,15 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,snd_pt,nesd,idx)
idx_pt = snd_pt rcv_pt = rcv_pt + n*nerv
call y%gth(idx_pt,nesd,idx) snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1567,18 +1571,16 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1589,7 +1591,8 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1609,14 +1612,13 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nesd>0) then if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1642,26 +1644,29 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1) & y%combuf(rcv_pt:rcv_pt+n*nerv-1)
call y%sct(rcv_pt,nerv,idx,beta) call y%sct(idx_pt,rcv_pt,nerv,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1525,7 +1525,8 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0
@ -1555,21 +1556,22 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
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),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),n*nesd,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1578,16 +1580,15 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,rcv_pt,nerv,idx)
rcv_pt = rcv_pt + n*nerv
idx_pt = rcv_pt snd_pt = snd_pt + n*nesd
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1603,18 +1604,17 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_r_spk_,prcid(i),& & psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1625,7 +1625,8 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1645,14 +1646,13 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_real_swap_tag p2ptag = psb_real_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nerv>0) then if (nerv>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1678,26 +1678,30 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1) & y%combuf(snd_pt:snd_pt+n*nesd-1)
call y%sct(snd_pt,nesd,idx,beta) call y%sct(idx_pt,snd_pt,nesd,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1495,7 +1495,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -1525,20 +1525,22 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm) call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,& call mpi_irecv(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' Gather ' if (debug) write(*,*) me,' Gather '
@ -1546,13 +1548,15 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,snd_pt,nesd,idx)
idx_pt = snd_pt rcv_pt = rcv_pt + n*nerv
call y%gth(idx_pt,nesd,idx) snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1567,18 +1571,16 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,& call mpi_isend(y%combuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1589,7 +1591,8 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1609,14 +1612,13 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nesd>0) then if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1642,26 +1644,29 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, &
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1) & y%combuf(rcv_pt:rcv_pt+n*nerv-1)
call y%sct(rcv_pt,nerv,idx,beta) call y%sct(idx_pt,rcv_pt,nerv,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

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

@ -1525,7 +1525,8 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999 goto 9999
endif endif
n=1 n = y%get_ncols()
swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0
@ -1555,21 +1556,22 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_realloc(totxch,prcid,info) call psb_realloc(totxch,prcid,info)
! First I post all the non blocking receives ! First I post all the non blocking receives
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
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),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt
call mpi_irecv(y%combuf(snd_pt),nesd,& call mpi_irecv(y%combuf(snd_pt),n*nesd,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret) & p2ptag, icomm,y%comid(i,2),iret)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1578,16 +1580,15 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! Then gather for sending. ! Then gather for sending.
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1
do i=1, totxch do i=1, totxch
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_ call y%gth(idx_pt,rcv_pt,nerv,idx)
rcv_pt = rcv_pt + n*nerv
idx_pt = rcv_pt snd_pt = snd_pt + n*nesd
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
@ -1603,18 +1604,17 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
! !
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_ idx_pt = 1+pnti+psb_n_elem_recv_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,& call mpi_isend(y%combuf(rcv_pt),n*nerv,&
& psb_mpi_c_dpk_,prcid(i),& & psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret) & p2ptag,icomm,y%comid(i,1),iret)
end if end if
@ -1625,7 +1625,8 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
end if end if
@ -1645,14 +1646,13 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
if (debug) write(*,*) me,' wait' if (debug) write(*,*) me,' wait'
pnti = 1 pnti = 1
snd_pt = totrcv_+1
rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag p2ptag = psb_dcomplex_swap_tag
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then if (proc_to_comm /= me)then
if (nerv>0) then if (nerv>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret) call mpi_wait(y%comid(i,1),p2pstat,iret)
@ -1678,26 +1678,30 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& 'Fatal error in swapdata: mismatch on self send',& & 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd & nerv,nesd
end if end if
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1)
end if end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do
if (debug) write(*,*) me,' scatter' if (debug) write(*,*) me,' scatter'
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = totrcv_+1
rcv_pt = 1 rcv_pt = 1
do i=1, totxch do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_) proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_) nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_) nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_ idx_pt = 1+pnti+nerv+psb_n_elem_send_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),& if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1) & y%combuf(snd_pt:snd_pt+n*nesd-1)
call y%sct(snd_pt,nesd,idx,beta) call y%sct(idx_pt,snd_pt,nesd,idx,beta)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3 pnti = pnti + nerv + nesd + 3
end do end do

12
base/modules/psb_c_base_vect_mod.f90
Unescape Escape View File

@ -2564,9 +2564,9 @@ contains
! !
! New comm internals impl. ! New comm internals impl.
! !
subroutine c_base_mlv_gthzbuf(i,n,idx,x) subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i,n integer(psb_ipk_) :: i, ixb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
class(psb_c_base_multivect_type) :: x class(psb_c_base_multivect_type) :: x
integer(psb_ipk_) :: nc integer(psb_ipk_) :: nc
@ -2578,7 +2578,7 @@ contains
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
nc = x%get_ncols() nc = x%get_ncols()
call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) call x%gth(n,idx%v(i:),x%combuf(ixb:))
end subroutine c_base_mlv_gthzbuf end subroutine c_base_mlv_gthzbuf
@ -2620,9 +2620,9 @@ contains
end subroutine c_base_mlv_sctb_x end subroutine c_base_mlv_sctb_x
subroutine c_base_mlv_sctb_buf(i,n,idx,beta,y) subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i, n integer(psb_ipk_) :: i, iyb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
complex(psb_spk_) :: beta complex(psb_spk_) :: beta
class(psb_c_base_multivect_type) :: y class(psb_c_base_multivect_type) :: y
@ -2635,7 +2635,7 @@ contains
if (y%is_dev()) call y%sync() if (y%is_dev()) call y%sync()
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
nc = y%get_ncols() nc = y%get_ncols()
call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) call y%sct(n,idx%v(i:),y%combuf(iyb:),beta)
call y%set_host() call y%set_host()
end subroutine c_base_mlv_sctb_buf end subroutine c_base_mlv_sctb_buf

12
base/modules/psb_d_base_vect_mod.f90
Unescape Escape View File

@ -2564,9 +2564,9 @@ contains
! !
! New comm internals impl. ! New comm internals impl.
! !
subroutine d_base_mlv_gthzbuf(i,n,idx,x) subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i,n integer(psb_ipk_) :: i, ixb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
class(psb_d_base_multivect_type) :: x class(psb_d_base_multivect_type) :: x
integer(psb_ipk_) :: nc integer(psb_ipk_) :: nc
@ -2578,7 +2578,7 @@ contains
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
nc = x%get_ncols() nc = x%get_ncols()
call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) call x%gth(n,idx%v(i:),x%combuf(ixb:))
end subroutine d_base_mlv_gthzbuf end subroutine d_base_mlv_gthzbuf
@ -2620,9 +2620,9 @@ contains
end subroutine d_base_mlv_sctb_x end subroutine d_base_mlv_sctb_x
subroutine d_base_mlv_sctb_buf(i,n,idx,beta,y) subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i, n integer(psb_ipk_) :: i, iyb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
real(psb_dpk_) :: beta real(psb_dpk_) :: beta
class(psb_d_base_multivect_type) :: y class(psb_d_base_multivect_type) :: y
@ -2635,7 +2635,7 @@ contains
if (y%is_dev()) call y%sync() if (y%is_dev()) call y%sync()
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
nc = y%get_ncols() nc = y%get_ncols()
call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) call y%sct(n,idx%v(i:),y%combuf(iyb:),beta)
call y%set_host() call y%set_host()
end subroutine d_base_mlv_sctb_buf end subroutine d_base_mlv_sctb_buf

12
base/modules/psb_i_base_vect_mod.f90
Unescape Escape View File

@ -1593,9 +1593,9 @@ contains
! !
! New comm internals impl. ! New comm internals impl.
! !
subroutine i_base_mlv_gthzbuf(i,n,idx,x) subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i,n integer(psb_ipk_) :: i, ixb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
class(psb_i_base_multivect_type) :: x class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: nc integer(psb_ipk_) :: nc
@ -1607,7 +1607,7 @@ contains
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
nc = x%get_ncols() nc = x%get_ncols()
call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) call x%gth(n,idx%v(i:),x%combuf(ixb:))
end subroutine i_base_mlv_gthzbuf end subroutine i_base_mlv_gthzbuf
@ -1649,9 +1649,9 @@ contains
end subroutine i_base_mlv_sctb_x end subroutine i_base_mlv_sctb_x
subroutine i_base_mlv_sctb_buf(i,n,idx,beta,y) subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i, n integer(psb_ipk_) :: i, iyb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
integer(psb_ipk_) :: beta integer(psb_ipk_) :: beta
class(psb_i_base_multivect_type) :: y class(psb_i_base_multivect_type) :: y
@ -1664,7 +1664,7 @@ contains
if (y%is_dev()) call y%sync() if (y%is_dev()) call y%sync()
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
nc = y%get_ncols() nc = y%get_ncols()
call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) call y%sct(n,idx%v(i:),y%combuf(iyb:),beta)
call y%set_host() call y%set_host()
end subroutine i_base_mlv_sctb_buf end subroutine i_base_mlv_sctb_buf

12
base/modules/psb_s_base_vect_mod.f90
Unescape Escape View File

@ -2564,9 +2564,9 @@ contains
! !
! New comm internals impl. ! New comm internals impl.
! !
subroutine s_base_mlv_gthzbuf(i,n,idx,x) subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i,n integer(psb_ipk_) :: i, ixb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
class(psb_s_base_multivect_type) :: x class(psb_s_base_multivect_type) :: x
integer(psb_ipk_) :: nc integer(psb_ipk_) :: nc
@ -2578,7 +2578,7 @@ contains
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
nc = x%get_ncols() nc = x%get_ncols()
call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) call x%gth(n,idx%v(i:),x%combuf(ixb:))
end subroutine s_base_mlv_gthzbuf end subroutine s_base_mlv_gthzbuf
@ -2620,9 +2620,9 @@ contains
end subroutine s_base_mlv_sctb_x end subroutine s_base_mlv_sctb_x
subroutine s_base_mlv_sctb_buf(i,n,idx,beta,y) subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i, n integer(psb_ipk_) :: i, iyb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
real(psb_spk_) :: beta real(psb_spk_) :: beta
class(psb_s_base_multivect_type) :: y class(psb_s_base_multivect_type) :: y
@ -2635,7 +2635,7 @@ contains
if (y%is_dev()) call y%sync() if (y%is_dev()) call y%sync()
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
nc = y%get_ncols() nc = y%get_ncols()
call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) call y%sct(n,idx%v(i:),y%combuf(iyb:),beta)
call y%set_host() call y%set_host()
end subroutine s_base_mlv_sctb_buf end subroutine s_base_mlv_sctb_buf

12
base/modules/psb_z_base_vect_mod.f90
Unescape Escape View File

@ -2564,9 +2564,9 @@ contains
! !
! New comm internals impl. ! New comm internals impl.
! !
subroutine z_base_mlv_gthzbuf(i,n,idx,x) subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i,n integer(psb_ipk_) :: i, ixb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
class(psb_z_base_multivect_type) :: x class(psb_z_base_multivect_type) :: x
integer(psb_ipk_) :: nc integer(psb_ipk_) :: nc
@ -2578,7 +2578,7 @@ contains
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
if (x%is_dev()) call x%sync() if (x%is_dev()) call x%sync()
nc = x%get_ncols() nc = x%get_ncols()
call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) call x%gth(n,idx%v(i:),x%combuf(ixb:))
end subroutine z_base_mlv_gthzbuf end subroutine z_base_mlv_gthzbuf
@ -2620,9 +2620,9 @@ contains
end subroutine z_base_mlv_sctb_x end subroutine z_base_mlv_sctb_x
subroutine z_base_mlv_sctb_buf(i,n,idx,beta,y) subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y)
use psi_serial_mod use psi_serial_mod
integer(psb_ipk_) :: i, n integer(psb_ipk_) :: i, iyb, n
class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: idx
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta
class(psb_z_base_multivect_type) :: y class(psb_z_base_multivect_type) :: y
@ -2635,7 +2635,7 @@ contains
if (y%is_dev()) call y%sync() if (y%is_dev()) call y%sync()
if (idx%is_dev()) call idx%sync() if (idx%is_dev()) call idx%sync()
nc = y%get_ncols() nc = y%get_ncols()
call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) call y%sct(n,idx%v(i:),y%combuf(iyb:),beta)
call y%set_host() call y%set_host()
end subroutine z_base_mlv_sctb_buf end subroutine z_base_mlv_sctb_buf

Write Preview
Loading…
Cancel
Save