fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-23 22:31:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
Alfredo Buttari
2005-10-06 16:00:01 +00:00
parent 8919dacf49
commit 3ca7ba61e5
17 changed files with 213 additions and 2815 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/comm/psb_dhalo.f90
+1 -1
View File
@@ -216,7 +216,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
character :: ltran
character(len=20) :: name, ch_err
name='psb_dhalom'
name='psb_dhalov'
info=0
call psb_erractionsave(err_act)
src/comm/psb_ihalo.f90
+3 -1
View File
@@ -70,7 +70,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
n = desc_a%matrix_data(psb_n_)
nrow = desc_a%matrix_data(psb_n_row_)
maxk=size(x,2)-jx+1
maxk=size(x,2)-ijx+1
if(present(ik)) then
if(ik.gt.maxk) then
@@ -237,7 +237,9 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode)
m = desc_a%matrix_data(psb_m_)
n = desc_a%matrix_data(psb_n_)
nrow = desc_a%matrix_data(psb_n_row_)
! ncol = desc_a%matrix_data(psb_n_col_)
if (present(tran)) then
ltran = tran
else
src/internals/psi_iswapdata.f90
+170 -150
View File
@@ -1,26 +1,27 @@
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod
use psb_descriptor_type
use mpi
implicit none
include 'mpif.h'
integer, intent(in) :: flag, n
integer, intent(out) :: info
integer :: y(:,:), beta
integer, target ::work(:)
type(psb_desc_type) :: desc_a
integer, intent(in) :: flag, n
integer, intent(out) :: info
integer :: y(:,:), beta
integer, target :: work(:)
type(psb_desc_type) :: desc_a
integer, optional :: data
! locals
integer :: icontxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,&
& err_act, totxch, ixrec, i, lw, idx_pt,&
& snd_pt, rcv_pt
integer :: blacs_pnum, krecvid, ksendid
integer, pointer, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, ptp, rvhd, h_idx
& sdsz, rvsz, prcid, ptp, rvhd, d_idx
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv
integer, pointer, dimension(:) :: sndbuf, rcvbuf
@@ -65,7 +66,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
end interface
info = 0
name='psi_iswapdata'
name='psi_dswap_data'
call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_)
@@ -91,23 +92,35 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
goto 9999
end if
swap_mpi = iand(flag,psb_swap_mpi_).ne.0
swap_mpi = iand(flag,psb_swap_mpi_) .ne.0
swap_sync = iand(flag,psb_swap_sync_).ne.0
swap_send = iand(flag,psb_swap_send_).ne.0
swap_recv = iand(flag,psb_swap_recv_).ne.0
h_idx => desc_a%halo_index
idxs = 0
idxr = 0
if(present(data)) then
if(data.eq.psb_comm_halo_) then
d_idx => desc_a%halo_index
else if(data.eq.psb_comm_ovr_) then
d_idx => desc_a%ovrlap_index
else
d_idx => desc_a%halo_index
end if
else
d_idx => desc_a%halo_index
end if
idxs = 1
idxr = 1
totxch = 0
point_to_proc = 1
rvhd(:) = mpi_request_null
! prepare info for communications
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm.ne.-1)
if(proc_to_comm .ne. myrow) totxch = totxch+1
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc
@@ -121,7 +134,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
idxs = idxs+sdsz(proc_to_comm)
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
if((idxr+idxs).lt.size(work)) then
@@ -140,18 +153,19 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
! gather elements into sendbuffer for swapping
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1))
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
! swap elements using mpi_alltoallv
@@ -167,32 +181,32 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
! scatter elements from receivebuffer after swapping
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y)
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_sync) then
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if (proc_to_comm .lt. myrow) then
! First I send
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call igesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive
@@ -205,51 +219,50 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call igesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then
! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1))
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y)
else
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow)
@@ -266,19 +279,20 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
! Then I post all the blocking sends
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1))
if(proc_to_comm .ne. myrow) then
@@ -294,7 +308,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
end if
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
do i=1, totxch
@@ -309,13 +323,13 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
if (ixrec .ne. mpi_undefined) then
ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index
point_to_proc = ptp(ixrec)
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y)
else
int_err(1) = ixrec
@@ -326,20 +340,20 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
end do
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm .eq. myrow) then
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
@@ -347,45 +361,45 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
else if (swap_send) then
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call igesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_recv) then
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y)
else
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,n,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
end if
@@ -403,34 +417,30 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
end subroutine psi_iswapdatam
subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_error_mod
use psb_descriptor_type
use mpi
implicit none
include 'mpif.h'
integer, intent(in) :: flag
integer, intent(out) :: info
integer :: y(:), beta
integer, target :: work(:)
type(psb_desc_type) :: desc_a
integer, intent(in) :: flag
integer, intent(out) :: info
integer :: y(:), beta
integer, target :: work(:)
type(psb_desc_type) :: desc_a
integer, optional :: data
! locals
integer :: icontxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,&
& err_act, totxch, ixrec, i, lw, idx_pt,&
& snd_pt, rcv_pt, n
integer, pointer, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, ptp, rvhd, h_idx
& sdsz, rvsz, prcid, ptp, rvhd, d_idx
integer :: blacs_pnum, krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv
@@ -476,7 +486,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
end interface
info = 0
name='psi_iswapdatav'
name='psi_iswap_datav'
call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_)
@@ -494,6 +504,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
call blacs_get(icontxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
& ptp(0:nprow-1), stat=info)
@@ -506,20 +517,32 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
swap_sync = iand(flag,psb_swap_sync_).ne.0
swap_send = iand(flag,psb_swap_send_).ne.0
swap_recv = iand(flag,psb_swap_recv_).ne.0
h_idx => desc_a%halo_index
idxs = 0
idxr = 0
if(present(data)) then
if(data.eq.psb_comm_halo_) then
d_idx => desc_a%halo_index
else if(data.eq.psb_comm_ovr_) then
d_idx => desc_a%ovrlap_index
else
d_idx => desc_a%halo_index
end if
else
d_idx => desc_a%halo_index
end if
idxs = 1
idxr = 1
totxch = 0
point_to_proc = 1
rvhd(:) = mpi_request_null
n=1
! prepare info for communications
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm.ne.-1)
if(proc_to_comm .ne. myrow) totxch = totxch+1
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc
@@ -533,7 +556,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
idxs = idxs+sdsz(proc_to_comm)
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
if((idxr+idxs).lt.size(work)) then
@@ -552,18 +575,18 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
! gather elements into sendbuffer for swapping
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
! swap elements using mpi_alltoallv
@@ -579,32 +602,32 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
! scatter elements from receivebuffer after swapping
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y)
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_sync) then
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if (proc_to_comm .lt. myrow) then
! First I send
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
call igesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive
@@ -617,51 +640,50 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
call igesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then
! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y)
else
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta,y)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow)
@@ -678,19 +700,19 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
! Then I post all the blocking sends
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
if(proc_to_comm .ne. myrow) then
@@ -706,7 +728,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
end if
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
do i=1, totxch
@@ -717,18 +739,17 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (ixrec .ne. mpi_undefined) then
ixrec=ixrec-1 ! mpi_waitany returns an 1 to nprow index
point_to_proc = ptp(ixrec)
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta,y)
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y)
else
int_err(1) = ixrec
info=400
@@ -738,66 +759,65 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
end do
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm .eq. myrow) then
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta,y)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_send) then
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,h_idx(idx_pt:idx_pt+nesd-1),&
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
call igesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
else if (swap_recv) then
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1)
nerv = h_idx(point_to_proc+psb_n_elem_recv_)
nesd = h_idx(point_to_proc+nerv+psb_n_elem_send_)
nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y)
else
idx_pt = point_to_proc+psb_elem_recv_
snd_pt = bsdidx(proc_to_comm)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta,y)
end if
point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
end do
end if
src/modules/psb_comm_mod.f90
+1 -1
View File
@@ -86,7 +86,7 @@ module psb_comm_mod
end subroutine psb_dscatterv
end interface
interface psb_dgather
interface psb_gather
subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
& iiglobx, ijglobx, iilocx,ijlocx,ik)
use psb_descriptor_type
src/modules/psb_tools_mod.f90
+5
View File
@@ -391,6 +391,11 @@ Module psb_tools_mod
type(psb_dspmat_type), intent(inout) ::a
integer, intent(out) :: info
end subroutine psb_dspfree
subroutine psb_dspfrees(a,info)
use psb_spmat_type
type(psb_dspmat_type), intent(inout) ::a
integer, intent(out) :: info
end subroutine psb_dspfrees
end interface
src/modules/psi_mod.f90
+4 -2
View File
@@ -73,19 +73,21 @@ module psi_mod
type(psb_desc_type) :: desc_a
integer, optional :: data
end subroutine psi_dswapdatav
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info)
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_descriptor_type
integer, intent(in) :: flag, n
integer, intent(out) :: info
integer :: y(:,:), beta, work(:)
type(psb_desc_type) :: desc_a
integer, optional :: data
end subroutine psi_iswapdatam
subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info)
subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_descriptor_type
integer, intent(in) :: flag
integer, intent(out) :: info
integer :: y(:), beta, work(:)
type(psb_desc_type) :: desc_a
integer, optional :: data
end subroutine psi_iswapdatav
end interface
src/prec/psb_dbldaggrmat.f90
+2 -1
View File
@@ -26,7 +26,7 @@ subroutine psb_dbldaggrmat(a,desc_a,p,info)
select case (p%iprcparm(smth_kind_))
case (no_smth_)
call raw_aggregate(info)
call raw_aggregate(info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='raw_aggregate')
@@ -289,6 +289,7 @@ contains
subroutine smooth_aggregate(info)
use psb_serial_mod
use psb_comm_mod
use psb_tools_mod
use psb_error_mod
implicit none
src/prec/psb_dprecbld.f90
+27 -4
View File
@@ -16,6 +16,18 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
type(psb_desc_type), intent(in) :: desc_a
character, intent(in), optional :: upd
interface psb_cslu
subroutine psb_dcslu(a,desc_data,p,upd,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbase_prec), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_dcslu
end interface
! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,icontxt,&
@@ -113,7 +125,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
call psb_errpush(info,name)
goto 9999
end if
call psb_dgelp('n',n_row,1,a%Pl,p%baseprecv(1)%d,n_col,WORK,n_row,info)
call psb_dgelp('n',a%Pl,p%baseprecv(1)%d,desc_a,info)
if(info /= 0) then
info=4010
ch_err='psb_dgelp'
@@ -126,7 +138,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
if (debug) then
allocate(gd(mglob))
call psb_dgather(gd, p%baseprecv(1)%d, desc_a, info, iroot=iroot)
call psb_gather(gd, p%baseprecv(1)%d, desc_a, info, iroot=iroot)
if(info /= 0) then
info=4010
ch_err='psb_dgatherm'
@@ -166,7 +178,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
select case(p%baseprecv(1)%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_dcslu(a,desc_a,p%baseprecv(1),iupd,info)
call psb_cslu(a,desc_a,p%baseprecv(1),iupd,info)
if(debug) write(0,*)me,': out of psb_dcslu'
if(info /= 0) then
info=4010
@@ -449,6 +461,17 @@ subroutine psb_mlprec_bld(a,desc_a,p,info)
integer :: i, nrg, nzg, err_act,k
character(len=20) :: name, ch_err
interface psb_splu
subroutine psb_dsplu(a,l,u,d,info,blck)
use psb_spmat_type
integer, intent(out) :: info
type(psb_dspmat_type),intent(in) :: a
type(psb_dspmat_type),intent(inout) :: l,u
type(psb_dspmat_type),intent(in), optional, target :: blck
real(kind(1.d0)), intent(inout) :: d(:)
end subroutine psb_dsplu
end interface
interface psb_genaggrmap
subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_spmat_type
@@ -527,7 +550,7 @@ subroutine psb_mlprec_bld(a,desc_a,p,info)
case(f_ilu_n_,f_ilu_e_)
call psb_spreall(p%av(l_pr_),nzg,info)
call psb_spreall(p%av(u_pr_),nzg,info)
call psb_dsplu(p%av(ac_),p%av(l_pr_),p%av(u_pr_),p%d,info)
call psb_splu(p%av(ac_),p%av(l_pr_),p%av(u_pr_),p%d,info)
if(info /= 0) then
info=4011
call psb_errpush(info,name)
src/prec/psb_dsplu.f90
-1
View File
@@ -170,7 +170,6 @@ contains
end if
do
! write(0,*)'++++',trw%infoa(psb_nnz_),size(trw%ia1),ktrw,k,i
if (ktrw > trw%infoa(psb_nnz_)) exit
if (trw%ia1(ktrw) > i) exit
k = trw%ia2(ktrw)