fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 20:32:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

[UPDATE] Mid commit to fix dist_graph_create

Browse Source
This commit is contained in:
Stack-1
2026-03-17 13:58:43 +01:00
parent 476167577f
commit dc61cbb0a2
14 changed files with 605 additions and 1918 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/comm/internals/psi_dswapdata.F90
+4 -2
View File
@@ -91,7 +91,7 @@ submodule (psi_d_comm_v_mod) psi_d_swapdata_impl
use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_
use psb_base_mod
contains
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,info,data,work)
#ifdef PSB_MPI_MOD
use mpi
@@ -476,6 +476,8 @@ contains
goto 9999
endif
icomm = ctxt%get_mpic()
do_start = iand(flag,psb_swap_start_) /= 0
do_wait = iand(flag,psb_swap_wait_) /= 0
@@ -604,7 +606,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,info,data,work)
#ifdef PSB_MPI_MOD
use mpi
#endif
base/comm/internals/psi_s_comm_v_mod@psi_s_ovrl_restr_v_impl.smod0
BIN
View File
Binary file not shown.
base/comm/internals/psi_sswapdata.F90
+74 -76
View File
@@ -93,7 +93,7 @@ submodule (psi_s_comm_v_mod) psi_s_swapdata_impl
use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_
use psb_base_mod
contains
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data,work)
#ifdef PSB_MPI_MOD
use mpi
@@ -108,7 +108,7 @@ contains
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
real(psb_spk_), target :: work(:)
real(psb_spk_), target, optional :: work(:)
integer(psb_ipk_), optional :: data
! locals
@@ -152,7 +152,7 @@ contains
data_ = psb_comm_halo_
end if
call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info)
call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@@ -175,13 +175,13 @@ contains
end if
if (baseline) then
call psi_dswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
call psi_sswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
if (info /= psb_success_) then
call psb_errpush(info,name,a_err='baseline swap')
goto 9999
end if
else if (neighbor_a2av) then
call psi_dswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
call psi_sswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
if (info /= psb_success_) then
call psb_errpush(info,name,a_err='neighbor a2av swap')
goto 9999
@@ -209,8 +209,8 @@ contains
! subroutine psi_sswap_baseline_vect
! This performs Isend/Irecv as a baseline communication mode
!
subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, &
& num_neighbors,total_send,total_recv,info)
#ifdef PSB_MPI_MOD
use mpi
@@ -220,14 +220,13 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
! locals
integer(psb_mpk_) :: np, me
@@ -235,7 +234,7 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
& iret, nesd, nerv
integer(psb_mpk_) :: icomm
integer(psb_mpk_), allocatable :: prcid(:)
integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,&
integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,&
& snd_pt, rcv_pt, pnti, n
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@@ -261,8 +260,8 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
totrcv_ = totrcv * n
totsnd_ = totsnd * n
total_recv_ = total_recv * n
total_send_ = total_send * n
call idx%sync()
if (debug) write(*,*) me,'Internal buffer'
@@ -279,12 +278,12 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
call y%new_comid(num_neighbors,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
call psb_realloc(num_neighbors,prcid,info)
! First I post all the non blocking receives
pnti = 1
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -305,7 +304,7 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
! Then gather for sending.
!
pnti = 1
do i=1, totxch
do i=1, num_neighbors
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
@@ -329,7 +328,7 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
snd_pt = 1
rcv_pt = 1
p2ptag = psb_real_swap_tag
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -362,12 +361,12 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
call psb_errpush(info,name,m_err=(/-2/))
goto 9999
end if
call psb_realloc(totxch,prcid,info)
call psb_realloc(num_neighbors,prcid,info)
if (debug) write(*,*) me,' wait'
pnti = 1
p2ptag = psb_real_swap_tag
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -406,7 +405,7 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -450,8 +449,8 @@ subroutine psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
end subroutine psi_sswap_baseline_vect
subroutine psi_sswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
subroutine psi_sswap_neighbor_topology_vect(ctxt,flag,beta,y,idx, &
& num_neighbors,total_send,total_recv,info)
#ifdef PSB_MPI_MOD
use mpi
@@ -462,14 +461,13 @@ subroutine psi_sswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, &
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
! locals
integer(psb_mpk_) :: np, me
@@ -490,6 +488,8 @@ subroutine psi_sswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, &
goto 9999
endif
icomm = ctxt%get_mpic()
do_start = iand(flag,psb_swap_start_) /= 0
do_wait = iand(flag,psb_swap_wait_) /= 0
@@ -503,7 +503,7 @@ subroutine psi_sswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, &
! Lazy initialization: build the topology on first call
if (.not. y%neighbor_topology%is_initialized) then
if (debug) write(*,*) me,' nbr_vect: building topology'
call y%neighbor_topology%init(idx%v, totxch, totsnd, totrcv, &
call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, &
& ctxt, icomm, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, &
@@ -620,7 +620,7 @@ end subroutine psi_sswap_neighbor_topology_vect
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data,work)
#ifdef PSB_MPI_MOD
use mpi
#endif
@@ -634,7 +634,7 @@ end subroutine psi_sswap_neighbor_topology_vect
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
real(psb_spk_), target :: work(:)
real(psb_spk_), target, optional :: work(:)
integer(psb_ipk_), optional :: data
! locals
@@ -648,8 +648,8 @@ end subroutine psi_sswap_neighbor_topology_vect
logical :: baseline, neighbor_a2av
info=psb_success_
name='psi_sswapdata_multivect'
info = psb_success_
name = 'psi_sswapdata_multivect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@@ -674,7 +674,7 @@ end subroutine psi_sswap_neighbor_topology_vect
data_ = psb_comm_halo_
end if
call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info)
call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@@ -690,8 +690,6 @@ end subroutine psi_sswap_neighbor_topology_vect
baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync
neighbor_a2av = swap_start .or. swap_wait
icomm = ctxt%get_mpic()
if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then
info=psb_err_mpi_error_
call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true')
@@ -700,13 +698,13 @@ end subroutine psi_sswap_neighbor_topology_vect
if (baseline) then
call psi_dswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
call psi_sswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
if (info /= psb_success_) then
call psb_errpush(info,name,a_err='baseline swap')
goto 9999
end if
else if (neighbor_a2av) then
call psi_dswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
call psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info)
if (info /= psb_success_) then
call psb_errpush(info,name,a_err='neighbor a2av swap')
goto 9999
@@ -730,8 +728,8 @@ end subroutine psi_sswap_neighbor_topology_vect
subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
subroutine psi_sswap_baseline_multivect(ctxt,flag,beta,y,idx, &
& num_neighbors,total_send,total_recv,info)
#ifdef PSB_MPI_MOD
use mpi
@@ -741,29 +739,28 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
! locals
integer(psb_mpk_) :: np, me, nesd, nerv, n
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpk_) :: icomm
integer(psb_mpk_), allocatable :: prcid(:)
integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,&
integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,&
& snd_pt, rcv_pt, pnti
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
info = psb_success_
name = 'psi_sswap_baseline_multivect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then
@@ -782,8 +779,8 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
totrcv_ = totrcv * n
totsnd_ = totsnd * n
total_recv_ = total_recv * n
total_send_ = total_send * n
call idx%sync()
@@ -801,14 +798,14 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
end if
if (debug) write(*,*) me,'do_send start'
call y%new_buffer(ione*size(idx%v),info)
call y%new_comid(totxch,info)
call y%new_comid(num_neighbors,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
call psb_realloc(num_neighbors,prcid,info)
! First I post all the non blocking receives
pnti = 1
snd_pt = totrcv_+1
snd_pt = total_recv_+1
rcv_pt = 1
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -829,9 +826,9 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
! Then gather for sending.
!
pnti = 1
snd_pt = totrcv_+1
snd_pt = total_recv_+1
rcv_pt = 1
do i=1, totxch
do i=1, num_neighbors
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
@@ -852,10 +849,10 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
!
pnti = 1
snd_pt = totrcv_+1
snd_pt = total_recv_+1
rcv_pt = 1
p2ptag = psb_real_swap_tag
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -887,14 +884,14 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
call psb_errpush(info,name,m_err=(/-2/))
goto 9999
end if
call psb_realloc(totxch,prcid,info)
call psb_realloc(num_neighbors,prcid,info)
if (debug) write(*,*) me,' wait'
pnti = 1
snd_pt = totrcv_+1
snd_pt = total_recv_+1
rcv_pt = 1
p2ptag = psb_real_swap_tag
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -930,9 +927,9 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = totrcv_+1
snd_pt = total_recv_+1
rcv_pt = 1
do i=1, totxch
do i=1, num_neighbors
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
@@ -975,8 +972,8 @@ subroutine psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
end subroutine psi_sswap_baseline_multivect
subroutine psi_sswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
subroutine psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, &
& num_neighbors,total_send,total_recv,info)
#ifdef PSB_MPI_MOD
use mpi
@@ -987,14 +984,13 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, &
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
! locals
integer(psb_mpk_) :: np, me
@@ -1006,7 +1002,7 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, &
info = psb_success_
name = 'psi_sswap_nbr_vect'
name = 'psi_sswap_neighbor_topology_multivect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then
@@ -1015,6 +1011,8 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, &
goto 9999
endif
icomm = ctxt%get_mpic()
do_start = iand(flag,psb_swap_start_) /= 0
do_wait = iand(flag,psb_swap_wait_) /= 0
@@ -1028,7 +1026,7 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, &
! Lazy initialization: build the topology on first call
if (.not. y%neighbor_topology%is_initialized) then
if (debug) write(*,*) me,' nbr_vect: building topology'
call y%neighbor_topology%init(idx%v, totxch, totsnd, totrcv, &
call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, &
& ctxt, icomm, info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_, name, &
base/comm/internals/psi_sswaptran.F90
+30 -30
View File
@@ -94,7 +94,7 @@
submodule (psi_s_comm_v_mod) psi_s_swaptran_impl
use psb_base_mod
contains
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data,work)
#ifdef PSB_MPI_MOD
use mpi
@@ -106,11 +106,11 @@ contains
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@@ -185,14 +185,14 @@ contains
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals
integer(psb_mpk_) :: np, me, nesd, nerv, n
@@ -430,7 +430,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data,work)
#ifdef PSB_MPI_MOD
use mpi
@@ -442,11 +442,11 @@ contains
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@@ -455,8 +455,8 @@ contains
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
info=psb_success_
name='psi_swap_tranv'
info = psb_success_
name = 'psi_sswaptran_multivect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@@ -522,14 +522,14 @@ contains
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals
integer(psb_mpk_) :: np, me, nesd, nerv, n
base/comm/psb_dhalo.f90
+3 -3
View File
@@ -157,7 +157,8 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,dzero,x%v,desc_a,iwork,info,data=data_)
call psi_swapdata(flag=imode, info=info, y=x%v, beta=dzero, desc_a=desc_a, &
& data=data_, work=iwork)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,done,x%v,desc_a,iwork,info)
else
@@ -311,8 +312,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,dzero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(flag=imode, info=info, y=x%v, beta=dzero, desc_a=desc_a, data=data_, work=iwork)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,done,x%v,&
& desc_a,iwork,info)
base/comm/psb_dovrl.f90
+4 -4
View File
@@ -161,8 +161,8 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,done,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(flag=mode_, beta=done, y=x%v, desc_a=desc_a, &
& data=psb_comm_ovr_, info=info, work=iwork)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@@ -313,8 +313,8 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,done,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(flag=mode_, beta=done, y=x%v, desc_a=desc_a, &
& data=psb_comm_ovr_, info=info, work=iwork)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
base/comm/psb_shalo.f90
+6 -8
View File
@@ -157,11 +157,11 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,szero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(flag=imode, beta=szero, y=x%v, desc_a=desc_a, &
& data=data_, info=info, work=iwork)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,sone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(flag=imode, beta=sone, y=x%v, desc_a=desc_a, &
& info=info, work=iwork)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@@ -313,11 +313,9 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,szero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(flag=imode, beta=szero, y=x%v, desc_a=desc_a, info=info, data=data_, work=iwork)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,sone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(flag=imode, beta=sone, y=x%v, desc_a=desc_a, info=info, work=iwork)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
base/comm/psb_sovrl.f90
+1 -2
View File
@@ -161,8 +161,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,sone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(flag=mode_, beta=sone, y=x%v, desc_a=desc_a, info=info, data=psb_comm_ovr_, work=iwork)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
base/modules/comm/psi_d_comm_v_mod.f90
+4 -4
View File
@@ -40,23 +40,23 @@ module psi_d_comm_v_mod
! Wrapper that calls different communications schemes depending on
! flag variable using communication buff obtained from desc_a%get_list_p
! ---------------------------------------------------------------
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), optional, target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_dpk_), optional, target :: work(:)
end subroutine psi_dswapdata_vect
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), optional, target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_dpk_), optional, target :: work(:)
end subroutine psi_dswapdata_multivect
end interface psi_swapdata
base/modules/comm/psi_s_comm_v_mod.f90
+16 -16
View File
@@ -36,46 +36,46 @@ module psi_s_comm_v_mod
use psb_s_base_multivect_mod, only : psb_s_base_multivect_type
interface psi_swapdata
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
end subroutine psi_sswapdata_vect
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
end subroutine psi_sswapdata_multivect
end interface psi_swapdata
interface psi_swaptran
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
end subroutine psi_sswaptran_vect
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
end subroutine psi_sswaptran_multivect
module subroutine psi_stran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
@@ -84,7 +84,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_stran_vidx_vect
@@ -95,7 +95,7 @@ module psi_s_comm_v_mod
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target :: work(:)
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_stran_vidx_multivect
base/psblas/psb_dspmm.f90
+22 -20
View File
@@ -202,14 +202,14 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(flag=psb_swap_send_, beta=dzero, y=x%v, desc_a=desc_a, &
& data=psb_comm_halo_, info=info, work=iwork)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(flag=psb_swap_recv_, beta=dzero, y=x%v, desc_a=desc_a, &
& data=psb_comm_halo_, info=info, work=iwork)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,done,y%v,info)
@@ -223,10 +223,10 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (doswap_) then
call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=dzero, y=x%v, desc_a=desc_a, &
& data=psb_comm_halo_, info=info, work=iwork)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
@@ -267,11 +267,10 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999
end if
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& done,y%v,desc_a,iwork,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& done,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
if (doswap_) then
call psi_swaptran(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, y=y%v, desc_a=desc_a, info=info, work=iwork)
if (info == psb_success_) call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, y=y%v, desc_a=desc_a, &
& data=psb_comm_ovr_, info=info, work=iwork)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
@@ -597,13 +596,16 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
end if
if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (doswap_)then
ik = lik ! This should not be an issue, we are expecting the values
! to be small, within PSB_IPK
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& ik,done,y(:,1:ik),desc_a,iwork,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_)
if (doswap_) then
call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=dzero, &
& y=x(:,1:lik), desc_a=desc_a, data=psb_comm_halo_, info=info, work=iwork)
end if
call psi_swaptran(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, &
& y=y(:,1:ik), desc_a=desc_a, info=info, work=iwork)
if (info == psb_success_) then
call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, &
& y=y(:,1:ik), desc_a=desc_a, data=psb_comm_ovr_, info=info, work=iwork)
end if
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
log.txt
+127 -1753
View File
File diff suppressed because one or more lines are too long
test/comm/Makefile
+33
View File
@@ -0,0 +1,33 @@
INSTALLDIR=../..
INCDIR=$(INSTALLDIR)/include/
MODDIR=$(INSTALLDIR)/modules/
include $(INCDIR)/Make.inc.psblas
#
# Libraries used
#
LIBDIR=$(INSTALLDIR)/lib/
PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_linsolve -lpsb_prec -lpsb_base
LDLIBS=$(PSBLDLIBS)
FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG).
TOBJS=psb_comm_test.o
EXEDIR=./runs
all: runsd psb_comm_test
runsd:
(if test ! -d runs ; then mkdir runs; fi)
psb_comm_test: $(TOBJS)
$(FLINK) $(LOPT) $(TOBJS) -o psb_comm_test $(PSBLAS_LIB) $(LDLIBS)
/bin/mv psb_comm_test $(EXEDIR)
clean:
/bin/rm -f $(TOBJS) $(TOBJS_API) *$(.mod) $(EXEDIR)/psb_comm_test
lib:
(cd ../../; make library)
verycleanlib:
(cd ../../; make veryclean)
test/comm/psb_comm_test.F90
+281
View File
@@ -0,0 +1,281 @@
!
! Test program for D-type halo exchange: baseline vs neighbor topology.
!
! This test exercises the lower-level psi_swapdata interface directly
! to compare the two communication paths implemented in psi_dswapdata.F90:
!
! 1. Baseline (Isend/Irecv) : flag = IOR(psb_swap_send_, psb_swap_recv_)
! 2. Neighbor topology (Ineighbor_alltoallv) : flag = psb_swap_start_ then psb_swap_wait_
!
! It builds a 3D block-partitioned descriptor with a 7-point stencil,
! fills owned entries with their global index, performs halo exchange
! via both paths, then checks:
! (a) The two paths produce identical results (cross-check)
! (b) Every halo entry equals the global index of its source (absolute check)
!
! Run with: mpirun -np <P> ./test_halo_new
!
program psb_comm_test
use psb_base_mod
use psi_mod
implicit none
! ---- parameters ----
integer(psb_ipk_) :: idim
integer(psb_ipk_) :: argc
character(len=32) :: arg
! ---- descriptor / context ----
type(psb_ctxt_type) :: ctxt
type(psb_desc_type) :: desc_a
integer(psb_ipk_) :: my_rank, np, info, i, nr, number_of_local_rows
integer(psb_lpk_) :: m, nt
integer(psb_lpk_), allocatable :: myidx(:)
! ---- vectors ----
type(psb_d_vect_type) :: v_baseline, v_neighbor
! ---- temporary / comparison arrays ----
real(psb_dpk_), allocatable :: vals(:)
real(psb_dpk_), allocatable :: result_baseline(:), result_neighbor(:)
real(psb_dpk_), allocatable :: expected(:)
! ---- halo index bookkeeping ----
integer(psb_ipk_) :: nrow, ncol, num_neighbors, send_indexes, receive_indexes
class(psb_i_base_vect_type), pointer :: halo_indexes
! ---- error / reporting ----
integer(psb_ipk_) :: n_pass, n_total, imode
real(psb_dpk_) :: err, tol
integer(psb_lpk_), allocatable :: glob_col(:)
character(len=40) :: name
name = 'test_halo_new'
tol = 1.0d-12
n_pass = 0
n_total = 0
! ---- parse command-line argument for idim ----
idim = 10
argc = command_argument_count()
do i = 1, argc
call get_command_argument(i, arg)
if (trim(arg) == '--dim') then
if (i < argc) then
call get_command_argument(i+1, arg)
read(arg, *) idim
exit
end if
end if
end do
if (idim <= 0) then
write(*,*) 'Invalid dimension specified. Usage: --dim <positive integer>'
call psb_abort(ctxt)
end if
! ==================================================================
! 1. Initialise MPI / PSBLAS context
! ==================================================================
call psb_init(ctxt)
call psb_info(ctxt, my_rank, np)
if (my_rank == 0) then
write(psb_out_unit,'("================================================")')
write(psb_out_unit,'(" Test: D-type halo baseline vs neighbor topo")')
write(psb_out_unit,'(" Processes : ",i0)') np
write(psb_out_unit,'(" Grid : ",i0," x ",i0," x ",i0)') idim,idim,idim
write(psb_out_unit,'("================================================")')
end if
! ==================================================================
! 2. Build descriptor with 7-point stencil connectivity
! ==================================================================
m = (1_psb_lpk_ * idim) * idim * idim
nt = (m + np - 1) / np
nr = max(0, min(int(nt,psb_ipk_), int(m - (my_rank * nt),psb_ipk_)))
call psb_cdall(ctxt, desc_a, info, nl=nr)
if (info /= psb_success_) then
write(psb_err_unit,*) my_rank, 'cdall error:', info
call psb_abort(ctxt)
end if
myidx = desc_a%get_global_indices()
number_of_local_rows = size(myidx)
do i = 1, number_of_local_rows
call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)/), desc_a, info)
if (myidx(i) > 1) &
& call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)-1/), desc_a, info)
if (myidx(i) < m) &
& call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)+1/), desc_a, info)
if (myidx(i) > idim) &
& call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)-idim/), desc_a, info)
if (myidx(i) + idim <= m) &
& call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)+idim/), desc_a, info)
if (myidx(i) > int(idim,psb_lpk_)*idim) &
& call psb_cdins(1_psb_ipk_, (/myidx(i)/), &
& (/myidx(i) - int(idim,psb_lpk_)*idim/), desc_a, info)
if (myidx(i) + int(idim,psb_lpk_)*idim <= m) &
& call psb_cdins(1_psb_ipk_, (/myidx(i)/), &
& (/myidx(i) + int(idim,psb_lpk_)*idim/), desc_a, info)
end do
call psb_cdasb(desc_a, info)
if (info /= psb_success_) then
write(psb_err_unit,*) my_rank, 'cdasb error:', info
call psb_abort(ctxt)
end if
nrow = desc_a%get_local_rows() ! owned
ncol = desc_a%get_local_cols() ! owned + halo
! ==================================================================
! 3. Allocate two D vectors (scratch) and fill owned entries
! ==================================================================
call psb_geall(v_baseline, desc_a, info)
call psb_geall(v_neighbor, desc_a, info)
call psb_geasb(v_baseline, desc_a, info, scratch=.true.)
call psb_geasb(v_neighbor, desc_a, info, scratch=.true.)
! Fill owned entries with the global index value
allocate(vals(ncol))
vals = dzero
do i = 1, number_of_local_rows
vals(i) = real(myidx(i), psb_dpk_)
end do
call v_baseline%set_vect(vals)
call v_neighbor%set_vect(vals)
deallocate(vals)
! ==================================================================
! 4. Build the expected result for halo positions
! glob_col(j) = global index of local column j
! After halo exchange every position j should hold glob_col(j).
! ==================================================================
allocate(glob_col(ncol), expected(ncol))
glob_col = desc_a%get_global_indices(owned=.false.)
do i = 1, ncol
expected(i) = real(glob_col(i), psb_dpk_)
end do
! ==================================================================
! 6. Baseline halo exchange (Isend/Irecv in one call)
! ==================================================================
imode = IOR(psb_swap_send_, psb_swap_recv_)
! v_baseline%v is a psb_d_base_vect_type
call psi_swapdata(flag=imode, beta=dzero, y=v_baseline%v, desc_a=desc_a, info=info, data=psb_comm_halo_)
if (info /= psb_success_) then
write(psb_err_unit,*) my_rank, 'baseline swap error:', info
call psb_abort(ctxt)
end if
! ==================================================================
! 7. Neighbor topology halo exchange (start + wait)
! ==================================================================
imode = psb_swap_start_
call psi_swapdata(imode, dzero, v_neighbor%v, desc_a, info, data=psb_comm_halo_)
if (info /= psb_success_) then
write(psb_err_unit,*) my_rank, 'neighbor start error:', info
call psb_abort(ctxt)
end if
imode = psb_swap_wait_
call psi_swapdata(imode, dzero, v_neighbor%v, desc_a, info, data=psb_comm_halo_)
if (info /= psb_success_) then
write(psb_err_unit,*) my_rank, 'neighbor wait error:', info
call psb_abort(ctxt)
end if
! ==================================================================
! 8. Extract results and compare
! ==================================================================
result_baseline = v_baseline%get_vect()
result_neighbor = v_neighbor%get_vect()
! ---- Test 1: cross-check baseline vs neighbor (all entries) ----
n_total = n_total + 1
err = maxval(abs(result_baseline(1:ncol) - result_neighbor(1:ncol)))
call psb_amx(ctxt, err)
if (my_rank == 0) then
if (err < tol) then
write(psb_out_unit,'(" [PASS] cross-check baseline vs neighbor : err = ",es12.5)') err
n_pass = n_pass + 1
else
write(psb_out_unit,'(" [FAIL] cross-check baseline vs neighbor : err = ",es12.5)') err
end if
end if
! ---- Test 2: baseline absolute correctness (halo = global index) ----
n_total = n_total + 1
err = maxval(abs(result_baseline(1:ncol) - expected(1:ncol)))
call psb_amx(ctxt, err)
if (my_rank == 0) then
if (err < tol) then
write(psb_out_unit,'(" [PASS] baseline absolute correctness : err = ",es12.5)') err
n_pass = n_pass + 1
else
write(psb_out_unit,'(" [FAIL] baseline absolute correctness : err = ",es12.5)') err
end if
end if
! ---- Test 3: neighbor absolute correctness (halo = global index) ----
n_total = n_total + 1
err = maxval(abs(result_neighbor(1:ncol) - expected(1:ncol)))
call psb_amx(ctxt, err)
if (my_rank == 0) then
if (err < tol) then
write(psb_out_unit,'(" [PASS] neighbor absolute correctness : err = ",es12.5)') err
n_pass = n_pass + 1
else
write(psb_out_unit,'(" [FAIL] neighbor absolute correctness : err = ",es12.5)') err
end if
end if
! ---- Test 4: repeat neighbor exchange (topology reuse) ----
! Reset halo entries to zero, run again, and check
do i = nrow+1, ncol
result_neighbor(i) = dzero
end do
call v_neighbor%set_vect(result_neighbor)
call psi_swapdata(psb_swap_start_, dzero, v_neighbor%v, desc_a, info, data=psb_comm_halo_)
call psi_swapdata(psb_swap_wait_, dzero, v_neighbor%v, desc_a, info, data=psb_comm_halo_)
result_neighbor = v_neighbor%get_vect()
n_total = n_total + 1
err = maxval(abs(result_neighbor(1:ncol) - expected(1:ncol)))
call psb_amx(ctxt, err)
if (my_rank == 0) then
if (err < tol) then
write(psb_out_unit,'(" [PASS] neighbor topology reuse : err = ",es12.5)') err
n_pass = n_pass + 1
else
write(psb_out_unit,'(" [FAIL] neighbor topology reuse : err = ",es12.5)') err
end if
end if
! ==================================================================
! 9. Summary
! ==================================================================
if (my_rank == 0) then
write(psb_out_unit,'("================================================")')
write(psb_out_unit,'(" Results: ",i0," / ",i0," tests passed")') n_pass, n_total
if (n_pass == n_total) then
write(psb_out_unit,'(" STATUS: ALL PASSED")')
else
write(psb_out_unit,'(" STATUS: SOME FAILURES")')
end if
write(psb_out_unit,'("================================================")')
end if
! ==================================================================
! 10. Cleanup
! ==================================================================
deallocate(result_baseline, result_neighbor, expected, glob_col)
call psb_gefree(v_baseline, desc_a, info)
call psb_gefree(v_neighbor, desc_a, info)
call psb_cdfree(desc_a, info)
call psb_exit(ctxt)
end program psb_comm_test