|
|
|
|
module test_psb_swapdata
|
|
|
|
|
use pfunit_mod
|
|
|
|
|
use psb_base_mod
|
|
|
|
|
implicit none
|
|
|
|
|
include 'mpif.h'
|
|
|
|
|
interface
|
|
|
|
|
subroutine psi_sswap_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
|
|
|
|
|
use psi_mod, psb_protect_name => psi_sswap_xchg_v
|
|
|
|
|
use psb_error_mod
|
|
|
|
|
use psb_realloc_mod
|
|
|
|
|
use psb_desc_mod
|
|
|
|
|
use psb_penv_mod
|
|
|
|
|
use psb_s_base_vect_mod
|
|
|
|
|
use iso_fortran_env
|
|
|
|
|
implicit none
|
|
|
|
|
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
|
real(psb_spk_) :: y(:)
|
|
|
|
|
real(psb_spk_) :: beta
|
|
|
|
|
class(psb_xch_idx_type), intent(inout) :: xchg
|
|
|
|
|
! locals
|
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
|
& proc_to_comm, p2ptag, iret
|
|
|
|
|
integer(psb_ipk_) :: nesd, nerv,&
|
|
|
|
|
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
|
|
|
|
|
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
|
|
|
|
|
integer :: count
|
|
|
|
|
real(psb_spk_), allocatable, save :: buffer(:)[:], sndbuf(:)
|
|
|
|
|
type(event_type), allocatable, save :: ufg(:)[:]
|
|
|
|
|
type(event_type), allocatable, save :: clear[:]
|
|
|
|
|
integer, save :: last_clear_count = 0
|
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
|
character(len=20) :: name
|
|
|
|
|
|
|
|
|
|
end subroutine psi_sswap_xchg_v
|
|
|
|
|
|
|
|
|
|
subroutine psi_sswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
|
|
|
|
|
use psi_mod, psb_protect_name => psi_sswap_xchg_m
|
|
|
|
|
use psb_error_mod
|
|
|
|
|
use psb_realloc_mod
|
|
|
|
|
use psb_desc_mod
|
|
|
|
|
use psb_penv_mod
|
|
|
|
|
use psb_s_base_vect_mod
|
|
|
|
|
use iso_fortran_env
|
|
|
|
|
implicit none
|
|
|
|
|
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag, m
|
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
|
real(psb_spk_) :: y(:,:)
|
|
|
|
|
real(psb_spk_) :: beta
|
|
|
|
|
class(psb_xch_idx_type), intent(inout) :: xchg
|
|
|
|
|
! locals
|
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
|
& proc_to_comm, p2ptag, iret
|
|
|
|
|
integer(psb_ipk_) :: nesd, nerv,&
|
|
|
|
|
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
|
|
|
|
|
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
|
|
|
|
|
integer :: count
|
|
|
|
|
real(psb_spk_), allocatable, save :: buffer(:)[:], sndbuf(:)
|
|
|
|
|
type(event_type), allocatable, save :: ufg(:)[:]
|
|
|
|
|
type(event_type), allocatable, save :: clear[:]
|
|
|
|
|
integer, save :: last_clear_count = 0
|
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
|
character(len=20) :: name
|
|
|
|
|
|
|
|
|
|
end subroutine psi_sswap_xchg_m
|
|
|
|
|
subroutine psi_dswap_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
|
|
|
|
|
use psi_mod, psb_protect_name => psi_dswap_xchg_v
|
|
|
|
|
use psb_error_mod
|
|
|
|
|
use psb_realloc_mod
|
|
|
|
|
use psb_desc_mod
|
|
|
|
|
use psb_penv_mod
|
|
|
|
|
use psb_d_base_vect_mod
|
|
|
|
|
use iso_fortran_env
|
|
|
|
|
implicit none
|
|
|
|
|
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
|
real(psb_dpk_) :: y(:)
|
|
|
|
|
real(psb_dpk_) :: beta
|
|
|
|
|
class(psb_xch_idx_type), intent(inout) :: xchg
|
|
|
|
|
! locals
|
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
|
& proc_to_comm, p2ptag, iret
|
|
|
|
|
integer(psb_ipk_) :: nesd, nerv,&
|
|
|
|
|
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
|
|
|
|
|
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
|
|
|
|
|
integer :: count
|
|
|
|
|
real(psb_dpk_), allocatable, save :: buffer(:)[:], sndbuf(:)
|
|
|
|
|
type(event_type), allocatable, save :: ufg(:)[:]
|
|
|
|
|
type(event_type), allocatable, save :: clear[:]
|
|
|
|
|
integer, save :: last_clear_count = 0
|
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
|
character(len=20) :: name
|
|
|
|
|
|
|
|
|
|
end subroutine psi_dswap_xchg_v
|
|
|
|
|
end interface
|
|
|
|
|
|
|
|
|
|
interface
|
|
|
|
|
subroutine psi_dswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
|
|
|
|
|
use psi_mod, psb_protect_name => psi_dswap_xchg_m
|
|
|
|
|
use psb_error_mod
|
|
|
|
|
use psb_realloc_mod
|
|
|
|
|
use psb_desc_mod
|
|
|
|
|
use psb_penv_mod
|
|
|
|
|
use psb_d_base_vect_mod
|
|
|
|
|
use iso_fortran_env
|
|
|
|
|
implicit none
|
|
|
|
|
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,m
|
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
|
real(psb_dpk_) :: y(:,:)
|
|
|
|
|
real(psb_dpk_) :: beta
|
|
|
|
|
class(psb_xch_idx_type), intent(inout) :: xchg
|
|
|
|
|
! locals
|
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
|
& proc_to_comm, p2ptag, iret
|
|
|
|
|
integer(psb_ipk_) :: nesd, nerv,&
|
|
|
|
|
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
|
|
|
|
|
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
|
|
|
|
|
integer :: count
|
|
|
|
|
real(psb_dpk_), allocatable, save :: buffer(:)[:], sndbuf(:)
|
|
|
|
|
type(event_type), allocatable, save :: ufg(:)[:]
|
|
|
|
|
type(event_type), allocatable, save :: clear[:]
|
|
|
|
|
integer, save :: last_clear_count = 0
|
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
|
character(len=20) :: name
|
|
|
|
|
end subroutine psi_dswap_xchg_m
|
|
|
|
|
end interface
|
|
|
|
|
|
|
|
|
|
contains
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_sswapdatav_2imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info
|
|
|
|
|
integer, parameter :: nrows=6
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:)
|
|
|
|
|
real(psb_spk_), allocatable :: val(:)
|
|
|
|
|
real(psb_spk_), allocatable :: y(:), check(:)
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_s_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 2) then
|
|
|
|
|
print*,'You need at least 2 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
!call psb_info(icontxt, me, np)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(ia(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(y(nrows))
|
|
|
|
|
i = 0
|
|
|
|
|
do j=1,size(vg,1)
|
|
|
|
|
vg(j)= i
|
|
|
|
|
i = i+1
|
|
|
|
|
if (i==np) then
|
|
|
|
|
i=0
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Use only 2 processes
|
|
|
|
|
!Assuming nrows is a multiple of 2 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
mid=nrows/2
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, nrows
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,size(ia,1)
|
|
|
|
|
ia(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=mid + 1,nrows
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
if ( me == 1) call psb_cdins(nz=1,ia=(/mid/),ja=(/mid+1/), desc_a=desc_a, info=info)
|
|
|
|
|
if ( me == 2) call psb_cdins(nz=1,ia=(/mid+1/),ja=(/mid/), desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=ia, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
y = x%get_vect()
|
|
|
|
|
!Let's modify x, so we need to update halo indices
|
|
|
|
|
|
|
|
|
|
if ((me == 1).or.(me == 2)) then
|
|
|
|
|
y(mid +1)=y(mid+1) + 2.0
|
|
|
|
|
endif
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
call psi_sswap_xchg_v(iictxt,icomm,flag,0.0,y,xchg,info)
|
|
|
|
|
!GETTING BACK X
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
!Let's build the expected solution
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
if ((me == 1).or.(me==2)) then
|
|
|
|
|
allocate(check(mid+1))
|
|
|
|
|
else
|
|
|
|
|
allocate(check(1))
|
|
|
|
|
endif
|
|
|
|
|
if (me == 1 ) then
|
|
|
|
|
check(1:mid)=1.0
|
|
|
|
|
check(mid + 1)=2.0
|
|
|
|
|
else if (me == 2) then
|
|
|
|
|
check(1:mid)=2.0
|
|
|
|
|
check(mid + 1)=1.0
|
|
|
|
|
else
|
|
|
|
|
check(1)=0.0
|
|
|
|
|
endif
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*y))
|
|
|
|
|
deallocate(vg,ia,val,y,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_sswapdatav_2imgs
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdatam_2imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info
|
|
|
|
|
integer, parameter :: nrows=6
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: y(:,:), check(:), v(:)
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 2) then
|
|
|
|
|
print*,'You need at least 2 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
!call psb_info(icontxt, me, np)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(ia(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
i = 0
|
|
|
|
|
do j=1,size(vg,1)
|
|
|
|
|
vg(j)= i
|
|
|
|
|
i = i+1
|
|
|
|
|
if (i==np) then
|
|
|
|
|
i=0
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Use only 2 processes
|
|
|
|
|
!Assuming nrows is a multiple of 2 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
mid=nrows/2
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, nrows
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,size(ia,1)
|
|
|
|
|
ia(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=mid + 1,nrows
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
if ( me == 1) call psb_cdins(nz=1,ia=(/mid/),ja=(/mid+1/), desc_a=desc_a, info=info)
|
|
|
|
|
if ( me == 2) call psb_cdins(nz=1,ia=(/mid+1/),ja=(/mid/), desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=ia, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
allocate(y(size(v,1),1))
|
|
|
|
|
y(:,1)=v
|
|
|
|
|
!Let's modify x, so we need to update halo indices
|
|
|
|
|
|
|
|
|
|
if ((me == 1).or.(me == 2)) then
|
|
|
|
|
y(mid +1,1)=y(mid+1,1) + 2.0d0
|
|
|
|
|
endif
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
call psi_dswap_xchg_m(iictxt,icomm,flag,1,0.0d0,y,xchg,info)
|
|
|
|
|
!GETTING BACK X
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
!Let's build the expected solution
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
if ((me == 1).or.(me==2)) then
|
|
|
|
|
allocate(check(mid+1))
|
|
|
|
|
else
|
|
|
|
|
allocate(check(1))
|
|
|
|
|
endif
|
|
|
|
|
if (me == 1 ) then
|
|
|
|
|
check(1:mid)=1.0d0
|
|
|
|
|
check(mid + 1)=2.0d0
|
|
|
|
|
else if (me == 2) then
|
|
|
|
|
check(1:mid)=2.0d0
|
|
|
|
|
check(mid + 1)=1.0d0
|
|
|
|
|
else
|
|
|
|
|
check(1)=0.0d0
|
|
|
|
|
endif
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*y(:,1)))
|
|
|
|
|
deallocate(vg,ia,val,y,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdatam_2imgs
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdatav_2imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info
|
|
|
|
|
integer, parameter :: nrows=6
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: y(:), check(:)
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 2) then
|
|
|
|
|
print*,'You need at least 2 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
!call psb_info(icontxt, me, np)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(ia(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(y(nrows))
|
|
|
|
|
i = 0
|
|
|
|
|
do j=1,size(vg,1)
|
|
|
|
|
vg(j)= i
|
|
|
|
|
i = i+1
|
|
|
|
|
if (i==np) then
|
|
|
|
|
i=0
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Use only 2 processes
|
|
|
|
|
!Assuming nrows is a multiple of 2 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
mid=nrows/2
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, nrows
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,size(ia,1)
|
|
|
|
|
ia(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=mid + 1,nrows
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
if ( me == 1) call psb_cdins(nz=1,ia=(/mid/),ja=(/mid+1/), desc_a=desc_a, info=info)
|
|
|
|
|
if ( me == 2) call psb_cdins(nz=1,ia=(/mid+1/),ja=(/mid/), desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=ia, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
y = x%get_vect()
|
|
|
|
|
!Let's modify x, so we need to update halo indices
|
|
|
|
|
|
|
|
|
|
if ((me == 1).or.(me == 2)) then
|
|
|
|
|
y(mid +1)=y(mid+1) + 2.0d0
|
|
|
|
|
endif
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
call psi_dswap_xchg_v(iictxt,icomm,flag,0.0d0,y,xchg,info)
|
|
|
|
|
!GETTING BACK X
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
!Let's build the expected solution
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
if ((me == 1).or.(me==2)) then
|
|
|
|
|
allocate(check(mid+1))
|
|
|
|
|
else
|
|
|
|
|
allocate(check(1))
|
|
|
|
|
endif
|
|
|
|
|
if (me == 1 ) then
|
|
|
|
|
check(1:mid)=1.0d0
|
|
|
|
|
check(mid + 1)=2.0d0
|
|
|
|
|
else if (me == 2) then
|
|
|
|
|
check(1:mid)=2.0d0
|
|
|
|
|
check(mid + 1)=1.0d0
|
|
|
|
|
else
|
|
|
|
|
check(1)=0.0d0
|
|
|
|
|
endif
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*y))
|
|
|
|
|
deallocate(vg,ia,val,y,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdatav_2imgs
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdata_2imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info
|
|
|
|
|
integer, parameter :: nrows=6
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: v(:), check(:)
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 2) then
|
|
|
|
|
print*,'You need at least 2 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
!call psb_info(icontxt, me, np)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(ia(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
i = 0
|
|
|
|
|
do j=1,size(vg,1)
|
|
|
|
|
vg(j)= i
|
|
|
|
|
i = i+1
|
|
|
|
|
if (i==np) then
|
|
|
|
|
i=0
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Use only 2 processes
|
|
|
|
|
!Assuming nrows is a multiple of 2 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
mid=nrows/2
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, nrows
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,size(ia,1)
|
|
|
|
|
ia(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=mid + 1,nrows
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
if ( me == 1) call psb_cdins(nz=1,ia=(/mid/),ja=(/mid+1/), desc_a=desc_a, info=info)
|
|
|
|
|
if ( me == 2) call psb_cdins(nz=1,ia=(/mid+1/),ja=(/mid/), desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=ia, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
!Let's modify x, so we need to update halo indices
|
|
|
|
|
|
|
|
|
|
if ((me == 1).or.(me == 2)) then
|
|
|
|
|
x%v%v(mid +1)=x%v%v(mid+1) + 2.0d0
|
|
|
|
|
endif
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
call psi_dswap_xchg_vect(iictxt,icomm,flag,0.0d0,x%v,xchg,info)
|
|
|
|
|
!GETTING BACK X
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
|
|
|
|
|
!Let's build the expected solution
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
if ((me == 1).or.(me==2)) then
|
|
|
|
|
allocate(check(mid+1))
|
|
|
|
|
else
|
|
|
|
|
allocate(check(1))
|
|
|
|
|
endif
|
|
|
|
|
if (me == 1 ) then
|
|
|
|
|
check(1:mid)=1.0d0
|
|
|
|
|
check(mid + 1)=2.0d0
|
|
|
|
|
else if (me == 2) then
|
|
|
|
|
check(1:mid)=2.0d0
|
|
|
|
|
check(mid + 1)=1.0d0
|
|
|
|
|
else
|
|
|
|
|
check(1)=0.0d0
|
|
|
|
|
endif
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*v))
|
|
|
|
|
deallocate(vg,ia,val,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdata_2imgs
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdata_4imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info, nz
|
|
|
|
|
integer, parameter :: nrows = 8
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:), ja(:), irw(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: v(:), check(:)
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 4) then
|
|
|
|
|
print*,'You need at least 4 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
|
|
|
|
|
!Use only 4 processes
|
|
|
|
|
!Assuming nrows is a multiple of 4 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
|
|
|
|
|
mid=nrows/4
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, 2*mid
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
do i=2*mid + 1, 3*mid
|
|
|
|
|
vg(i)=2
|
|
|
|
|
enddo
|
|
|
|
|
do i=3*mid+1, nrows
|
|
|
|
|
vg(i)=3
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
if (me == 1) nz = 5
|
|
|
|
|
if (me == 2) nz = 7
|
|
|
|
|
if (me == 3) nz = 7
|
|
|
|
|
if (me == 4) nz = 5
|
|
|
|
|
if (me > 4) nz = 0
|
|
|
|
|
|
|
|
|
|
allocate(ia(nz),ja(nz))
|
|
|
|
|
|
|
|
|
|
if (me == 1) then
|
|
|
|
|
|
|
|
|
|
ia(1)=2
|
|
|
|
|
ja(1)=1
|
|
|
|
|
|
|
|
|
|
ia(2)=1
|
|
|
|
|
ja(2)=2
|
|
|
|
|
|
|
|
|
|
ia(3)=2
|
|
|
|
|
ja(3)=3
|
|
|
|
|
|
|
|
|
|
ia(4)=1
|
|
|
|
|
ja(4)=4
|
|
|
|
|
|
|
|
|
|
ia(5)=2
|
|
|
|
|
ja(5)=5
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 2) then
|
|
|
|
|
|
|
|
|
|
ia(1)=4
|
|
|
|
|
ja(1)=1
|
|
|
|
|
|
|
|
|
|
ia(2)=3
|
|
|
|
|
ja(2)=2
|
|
|
|
|
|
|
|
|
|
ia(3)=4
|
|
|
|
|
ja(3)=3
|
|
|
|
|
|
|
|
|
|
ia(4)=3
|
|
|
|
|
ja(4)=4
|
|
|
|
|
|
|
|
|
|
ia(5)=4
|
|
|
|
|
ja(5)=5
|
|
|
|
|
|
|
|
|
|
ia(6)=3
|
|
|
|
|
ja(6)=6
|
|
|
|
|
|
|
|
|
|
ia(7)=4
|
|
|
|
|
ja(7)=6
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 3) then
|
|
|
|
|
ia(1)=5
|
|
|
|
|
ja(1)=2
|
|
|
|
|
|
|
|
|
|
ia(2)=6
|
|
|
|
|
ja(2)=3
|
|
|
|
|
|
|
|
|
|
ia(3)=5
|
|
|
|
|
ja(3)=4
|
|
|
|
|
|
|
|
|
|
ia(4)=6
|
|
|
|
|
ja(4)=5
|
|
|
|
|
|
|
|
|
|
ia(5)=5
|
|
|
|
|
ja(5)=6
|
|
|
|
|
|
|
|
|
|
ia(6)=6
|
|
|
|
|
ja(6)=7
|
|
|
|
|
|
|
|
|
|
ia(7)=5
|
|
|
|
|
ja(7)=8
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 4) then
|
|
|
|
|
ia(1)=7
|
|
|
|
|
ja(1)=4
|
|
|
|
|
|
|
|
|
|
ia(2)=8
|
|
|
|
|
ja(2)=5
|
|
|
|
|
|
|
|
|
|
ia(3)=7
|
|
|
|
|
ja(3)=6
|
|
|
|
|
|
|
|
|
|
ia(4)=8
|
|
|
|
|
ja(4)=7
|
|
|
|
|
|
|
|
|
|
ia(5)=7
|
|
|
|
|
ja(5)=8
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
do i= mid + 1, 2*mid
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
do i=2*mid + 1, 3*mid
|
|
|
|
|
val(i)=3.
|
|
|
|
|
enddo
|
|
|
|
|
do i=3*mid + 1, nrows
|
|
|
|
|
val(i)=4.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
|
|
|
|
|
call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info)
|
|
|
|
|
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
allocate(irw(nrows))
|
|
|
|
|
do i=1,nrows
|
|
|
|
|
irw(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=irw, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
if (me==1) nz = 5
|
|
|
|
|
if (me==2) nz = 6
|
|
|
|
|
if (me==3) nz = 7
|
|
|
|
|
if (me==4) nz = 5
|
|
|
|
|
if (me > 4) nz = 1
|
|
|
|
|
allocate (check(nz))
|
|
|
|
|
if (me == 1) then
|
|
|
|
|
check(1)=2
|
|
|
|
|
check(2)=2
|
|
|
|
|
check(3)=8
|
|
|
|
|
check(4)=8
|
|
|
|
|
check(5)=18
|
|
|
|
|
endif
|
|
|
|
|
if (me == 2) then
|
|
|
|
|
check(1)=8
|
|
|
|
|
check(2)=8
|
|
|
|
|
check(3)=2
|
|
|
|
|
check(4)=2
|
|
|
|
|
check(5)=18
|
|
|
|
|
check(6)=18
|
|
|
|
|
endif
|
|
|
|
|
if (me == 3) then
|
|
|
|
|
check(1)=18
|
|
|
|
|
check(2)=18
|
|
|
|
|
check(3)=1
|
|
|
|
|
check(4)=8
|
|
|
|
|
check(5)=8
|
|
|
|
|
check(6)=32
|
|
|
|
|
check(7)=32
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
if (me == 4) then
|
|
|
|
|
check(1)=32
|
|
|
|
|
check(2)=32
|
|
|
|
|
check(3)=8
|
|
|
|
|
check(4)=18
|
|
|
|
|
check(5)=18
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
!We can do something better here
|
|
|
|
|
x%v%v = x%v%v*2*me
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
call psi_dswap_xchg_vect(iictxt,icomm,flag,0.0d0,x%v,xchg,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*v))
|
|
|
|
|
deallocate(vg,ia,val,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdata_4imgs
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdata_8imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info, nz
|
|
|
|
|
integer, parameter :: nrows = 8
|
|
|
|
|
integer :: icontxt, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:), ja(:), irw(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: v(:), check(:)
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 8) then
|
|
|
|
|
print*,'You need at least 8 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
|
|
|
|
|
!Use only 8 processes
|
|
|
|
|
!Each process has a line
|
|
|
|
|
|
|
|
|
|
do i=1, nrows
|
|
|
|
|
vg(i)=i-1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
if (me == 1) nz = 1
|
|
|
|
|
if (me == 2) nz = 2
|
|
|
|
|
if (me == 3) nz = 3
|
|
|
|
|
if ((me >= 4).and.(me <= 8)) nz = 2
|
|
|
|
|
if (me > 8) nz = 0
|
|
|
|
|
allocate(ia(nz),ja(nz))
|
|
|
|
|
|
|
|
|
|
if (me == 1) then
|
|
|
|
|
|
|
|
|
|
ia(1)=1
|
|
|
|
|
ja(1)=6
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 2) then
|
|
|
|
|
|
|
|
|
|
ia(1)=2
|
|
|
|
|
ja(1)=1
|
|
|
|
|
|
|
|
|
|
ia(2)=2
|
|
|
|
|
ja(2)=7
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 3) then
|
|
|
|
|
ia(1)=3
|
|
|
|
|
ja(1)=1
|
|
|
|
|
|
|
|
|
|
ia(2)=3
|
|
|
|
|
ja(2)=2
|
|
|
|
|
|
|
|
|
|
ia(3)=3
|
|
|
|
|
ja(3)=8
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 4) then
|
|
|
|
|
ia(1)=4
|
|
|
|
|
ja(1)=2
|
|
|
|
|
|
|
|
|
|
ia(2)=4
|
|
|
|
|
ja(2)=3
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 5) then
|
|
|
|
|
ia(1)=5
|
|
|
|
|
ja(1)=3
|
|
|
|
|
|
|
|
|
|
ia(2)=5
|
|
|
|
|
ja(2)=4
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 6) then
|
|
|
|
|
ia(1)=6
|
|
|
|
|
ja(1)=4
|
|
|
|
|
|
|
|
|
|
ia(2)=6
|
|
|
|
|
ja(2)=5
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 7) then
|
|
|
|
|
ia(1)=7
|
|
|
|
|
ja(1)=5
|
|
|
|
|
|
|
|
|
|
ia(2)=7
|
|
|
|
|
ja(2)=6
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 8) then
|
|
|
|
|
ia(1)=8
|
|
|
|
|
ja(1)=6
|
|
|
|
|
|
|
|
|
|
ia(2)=8
|
|
|
|
|
ja(2)=7
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,nrows
|
|
|
|
|
val(i)=me
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
allocate(irw(nrows))
|
|
|
|
|
do i=1,nrows
|
|
|
|
|
irw(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=irw, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (me == 1) nz = 2
|
|
|
|
|
if (me == 2) nz = 3
|
|
|
|
|
if (me == 3) nz = 4
|
|
|
|
|
if ((me >= 4).and.(me <= 8)) nz = 3
|
|
|
|
|
if (me > 8) nz = 1
|
|
|
|
|
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
allocate (check(nz))
|
|
|
|
|
if (me == 1) then
|
|
|
|
|
check(1)=2
|
|
|
|
|
check(2)=12
|
|
|
|
|
endif
|
|
|
|
|
if (me == 2) then
|
|
|
|
|
check(1)=4
|
|
|
|
|
check(2)=2
|
|
|
|
|
check(3)=14
|
|
|
|
|
endif
|
|
|
|
|
if (me == 3) then
|
|
|
|
|
check(1)=6
|
|
|
|
|
check(2)=2
|
|
|
|
|
check(3)=4
|
|
|
|
|
check(4)=16
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
if (me == 4) then
|
|
|
|
|
check(1)=8
|
|
|
|
|
check(2)=4
|
|
|
|
|
check(3)=6
|
|
|
|
|
endif
|
|
|
|
|
if (me == 5) then
|
|
|
|
|
check(1)=10
|
|
|
|
|
check(2)=6
|
|
|
|
|
check(3)=8
|
|
|
|
|
endif
|
|
|
|
|
if (me == 6) then
|
|
|
|
|
check(1)=12
|
|
|
|
|
check(2)=8
|
|
|
|
|
check(3)=10
|
|
|
|
|
endif
|
|
|
|
|
if (me == 7) then
|
|
|
|
|
check(1)=14
|
|
|
|
|
check(2)=10
|
|
|
|
|
check(3)=12
|
|
|
|
|
endif
|
|
|
|
|
if (me == 8) then
|
|
|
|
|
check(1)=16
|
|
|
|
|
check(2)=12
|
|
|
|
|
check(3)=14
|
|
|
|
|
endif
|
|
|
|
|
if (me > 8) then
|
|
|
|
|
check(1)=0
|
|
|
|
|
endif
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
!We can do something better here
|
|
|
|
|
x%v%v = x%v%v + me
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
call psi_dswap_xchg_vect(iictxt,icomm,flag,0.0d0,x%v,xchg,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*v))
|
|
|
|
|
|
|
|
|
|
deallocate(vg,ia,val,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdata_8imgs
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdata_8imgs_b(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info, nz
|
|
|
|
|
integer, parameter :: nrows = 8
|
|
|
|
|
integer :: icontxt, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:), ja(:), irw(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: v(:), check(:)
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 8) then
|
|
|
|
|
print*,'You need at least 8 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
|
|
|
|
|
!Use only 8 processes
|
|
|
|
|
!Each process has a line
|
|
|
|
|
|
|
|
|
|
do i=1, nrows
|
|
|
|
|
vg(i)=i-1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
if (me == 1) nz = 7
|
|
|
|
|
if ((me >= 2).and.(me <= 8)) nz = 1
|
|
|
|
|
if (me > 8) nz = 0
|
|
|
|
|
allocate(ia(nz),ja(nz))
|
|
|
|
|
|
|
|
|
|
if (me == 1) then
|
|
|
|
|
|
|
|
|
|
ia(1)=1
|
|
|
|
|
ja(1)=2
|
|
|
|
|
|
|
|
|
|
ia(2)=1
|
|
|
|
|
ja(2)=3
|
|
|
|
|
|
|
|
|
|
ia(3)=1
|
|
|
|
|
ja(3)=4
|
|
|
|
|
|
|
|
|
|
ia(4)=1
|
|
|
|
|
ja(4)=5
|
|
|
|
|
|
|
|
|
|
ia(5)=1
|
|
|
|
|
ja(5)=6
|
|
|
|
|
|
|
|
|
|
ia(6)=1
|
|
|
|
|
ja(6)=7
|
|
|
|
|
|
|
|
|
|
ia(7)=1
|
|
|
|
|
ja(7)=8
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 2) then
|
|
|
|
|
ia(1)=2
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 3) then
|
|
|
|
|
ia(1)=3
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 4) then
|
|
|
|
|
ia(1)=4
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 5) then
|
|
|
|
|
ia(1)=5
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 6) then
|
|
|
|
|
ia(1)=6
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 7) then
|
|
|
|
|
ia(1)=7
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
if (me == 8) then
|
|
|
|
|
ia(1)=8
|
|
|
|
|
ja(1)=1
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,nrows
|
|
|
|
|
val(i)=me
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
allocate(irw(nrows))
|
|
|
|
|
do i=1,nrows
|
|
|
|
|
irw(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=irw, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (me == 1) nz = 8
|
|
|
|
|
if ((me >= 2).and.(me <= 8)) nz = 2
|
|
|
|
|
if (me > 8) nz = 1
|
|
|
|
|
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
allocate (check(nz))
|
|
|
|
|
if (me == 1) then
|
|
|
|
|
check(1)=2
|
|
|
|
|
check(2)=4
|
|
|
|
|
check(3)=6
|
|
|
|
|
check(4)=8
|
|
|
|
|
check(5)=10
|
|
|
|
|
check(6)=12
|
|
|
|
|
check(7)=14
|
|
|
|
|
check(8)=16
|
|
|
|
|
endif
|
|
|
|
|
if (me == 2) then
|
|
|
|
|
check(1)=4
|
|
|
|
|
check(2)=2
|
|
|
|
|
endif
|
|
|
|
|
if (me == 3) then
|
|
|
|
|
check(1)=6
|
|
|
|
|
check(2)=2
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
if (me == 4) then
|
|
|
|
|
check(1)=8
|
|
|
|
|
check(2)=2
|
|
|
|
|
endif
|
|
|
|
|
if (me == 5) then
|
|
|
|
|
check(1)=10
|
|
|
|
|
check(2)=2
|
|
|
|
|
endif
|
|
|
|
|
if (me == 6) then
|
|
|
|
|
check(1)=12
|
|
|
|
|
check(2)=2
|
|
|
|
|
endif
|
|
|
|
|
if (me == 7) then
|
|
|
|
|
check(1)=14
|
|
|
|
|
check(2)=2
|
|
|
|
|
endif
|
|
|
|
|
if (me == 8) then
|
|
|
|
|
check(1)=16
|
|
|
|
|
check(2)=2
|
|
|
|
|
endif
|
|
|
|
|
if (me > 8) then
|
|
|
|
|
check(1)=0
|
|
|
|
|
endif
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
!We can do something better here
|
|
|
|
|
x%v%v = x%v%v + me
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psi_dswap_xchg_vect(iictxt,icomm,flag,0.0d0,x%v,xchg,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*v))
|
|
|
|
|
|
|
|
|
|
deallocate(vg,ia,val,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdata_8imgs_b
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_swapdatatran_2imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info
|
|
|
|
|
integer, parameter :: nrows=6
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: val(:)
|
|
|
|
|
real(psb_dpk_), allocatable :: v(:), check(:)
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_d_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 2) then
|
|
|
|
|
print*,'You need at least 2 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
!call psb_info(icontxt, me, np)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(ia(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
i = 0
|
|
|
|
|
do j=1,size(vg,1)
|
|
|
|
|
vg(j)= i
|
|
|
|
|
i = i+1
|
|
|
|
|
if (i==np) then
|
|
|
|
|
i=0
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Use only 2 processes
|
|
|
|
|
!Assuming nrows is a multiple of 2 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
mid=nrows/2
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, nrows
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,size(ia,1)
|
|
|
|
|
ia(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=mid + 1,nrows
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
if ( me == 1) call psb_cdins(nz=1,ia=(/mid/),ja=(/mid+1/), desc_a=desc_a, info=info)
|
|
|
|
|
if ( me == 2) call psb_cdins(nz=1,ia=(/mid+1/),ja=(/mid/), desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=ia, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
!v = x%get_vect()
|
|
|
|
|
!Let's modify x, so we need to update halo indices
|
|
|
|
|
|
|
|
|
|
if ((me == 1).or.(me == 2)) then
|
|
|
|
|
call psb_geaxpby(dble(me),x,0.0d0,x,desc_a,info)
|
|
|
|
|
!x%v%v(mid +1)=x%v%v(mid+1) + 2.0d0
|
|
|
|
|
endif
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
sync all
|
|
|
|
|
|
|
|
|
|
call psi_dswaptran_xchg_vect(iictxt,icomm,flag,0.0d0,x%v,xchg,info)
|
|
|
|
|
!GETTING BACK X
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
sync all
|
|
|
|
|
|
|
|
|
|
!Let's build the expected solution
|
|
|
|
|
if ((me == 1).or.(me==2)) then
|
|
|
|
|
allocate(check(mid+1))
|
|
|
|
|
else
|
|
|
|
|
allocate(check(1))
|
|
|
|
|
endif
|
|
|
|
|
if (me == 1 )then
|
|
|
|
|
check(1:mid)=1.0d0
|
|
|
|
|
check(mid + 1)=2.0d0
|
|
|
|
|
else if (me == 2) then
|
|
|
|
|
check(1)=2.0d0
|
|
|
|
|
check(mid-1:mid)=4.0d0
|
|
|
|
|
check(mid + 1)=1.0d0
|
|
|
|
|
else
|
|
|
|
|
check(1)=0.0d0
|
|
|
|
|
endif
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
@assertEqual(real(true*check),real(true*v))
|
|
|
|
|
deallocate(vg,ia,val,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_swapdatatran_2imgs
|
|
|
|
|
|
|
|
|
|
@test(nimgs=[std])
|
|
|
|
|
subroutine test_psb_sswapdatam_2imgs(this)
|
|
|
|
|
implicit none
|
|
|
|
|
Class(CafTestMethod), intent(inout) :: this
|
|
|
|
|
integer :: msg, me, i=0, np, j, info
|
|
|
|
|
integer, parameter :: nrows=6
|
|
|
|
|
integer :: icontxt, mid, true
|
|
|
|
|
integer, allocatable :: vg(:), ia(:)
|
|
|
|
|
real(psb_spk_), allocatable :: val(:)
|
|
|
|
|
real(psb_spk_), allocatable :: y(:,:), check(:), v(:)
|
|
|
|
|
class(psb_xch_idx_type), pointer :: xchg
|
|
|
|
|
integer(psb_ipk_) :: iictxt, icomm, flag
|
|
|
|
|
type(psb_desc_type):: desc_a
|
|
|
|
|
type(psb_s_vect_type) :: x
|
|
|
|
|
|
|
|
|
|
np = this%getNumImages()
|
|
|
|
|
if (np < 2) then
|
|
|
|
|
print*,'You need at least 2 processes to run this test.'
|
|
|
|
|
return
|
|
|
|
|
endif
|
|
|
|
|
call psb_init(icontxt,np,MPI_COMM_WORLD)
|
|
|
|
|
!call psb_info(icontxt, me, np)
|
|
|
|
|
me = this_image()
|
|
|
|
|
!Allocate vectors
|
|
|
|
|
allocate(vg(nrows))
|
|
|
|
|
allocate(ia(nrows))
|
|
|
|
|
allocate(val(nrows))
|
|
|
|
|
allocate(v(nrows))
|
|
|
|
|
i = 0
|
|
|
|
|
do j=1,size(vg,1)
|
|
|
|
|
vg(j)= i
|
|
|
|
|
i = i+1
|
|
|
|
|
if (i==np) then
|
|
|
|
|
i=0
|
|
|
|
|
endif
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Use only 2 processes
|
|
|
|
|
!Assuming nrows is a multiple of 2 so mid is an integer
|
|
|
|
|
!Distribute equally to the two processes
|
|
|
|
|
mid=nrows/2
|
|
|
|
|
|
|
|
|
|
do i=1, mid
|
|
|
|
|
vg(i)=0
|
|
|
|
|
enddo
|
|
|
|
|
do i=mid+1, nrows
|
|
|
|
|
vg(i)=1
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
do i=1,size(ia,1)
|
|
|
|
|
ia(i)=i
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=1,mid
|
|
|
|
|
val(i)=1.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
do i=mid + 1,nrows
|
|
|
|
|
val(i)=2.
|
|
|
|
|
enddo
|
|
|
|
|
|
|
|
|
|
call psb_cdall(icontxt,desc_a,info, vg=vg)
|
|
|
|
|
if ( me == 1) call psb_cdins(nz=1,ia=(/mid/),ja=(/mid+1/), desc_a=desc_a, info=info)
|
|
|
|
|
if ( me == 2) call psb_cdins(nz=1,ia=(/mid+1/),ja=(/mid/), desc_a=desc_a, info=info)
|
|
|
|
|
call psb_cdasb(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_geall(x,desc_a,info)
|
|
|
|
|
call psb_geins(m=nrows, irw=ia, val=val,x=x, desc_a=desc_a, info=info)
|
|
|
|
|
call psb_geasb(x,desc_a,info)
|
|
|
|
|
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
v = x%get_vect()
|
|
|
|
|
allocate(y(size(v,1),1))
|
|
|
|
|
y(:,1)=v
|
|
|
|
|
!Let's modify x, so we need to update halo indices
|
|
|
|
|
|
|
|
|
|
if ((me == 1).or.(me == 2)) then
|
|
|
|
|
y(mid +1,1)=y(mid+1,1) + 2.0
|
|
|
|
|
endif
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
! END OF SETUP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
iictxt = desc_a%get_context()
|
|
|
|
|
|
|
|
|
|
icomm = desc_a%get_mpic()
|
|
|
|
|
|
|
|
|
|
call desc_a%get_list(psb_comm_halo_,xchg,info)
|
|
|
|
|
|
|
|
|
|
flag = IOR(psb_swap_send_, psb_swap_recv_)
|
|
|
|
|
|
|
|
|
|
print*,'size of y', size(y,1), size(y,2)
|
|
|
|
|
call psi_sswap_xchg_m(iictxt,icomm,flag,1,0.0,y,xchg,info)
|
|
|
|
|
!GETTING BACK X
|
|
|
|
|
call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
!Let's build the expected solution
|
|
|
|
|
if (allocated(check)) deallocate(check)
|
|
|
|
|
if ((me == 1).or.(me==2)) then
|
|
|
|
|
allocate(check(mid+1))
|
|
|
|
|
else
|
|
|
|
|
allocate(check(1))
|
|
|
|
|
endif
|
|
|
|
|
if (me == 1 ) then
|
|
|
|
|
check(1:mid)=1.0
|
|
|
|
|
check(mid + 1)=2.0
|
|
|
|
|
else if (me == 2) then
|
|
|
|
|
check(1:mid)=2.0
|
|
|
|
|
check(mid + 1)=1.0
|
|
|
|
|
else
|
|
|
|
|
check(1)=0.0
|
|
|
|
|
endif
|
|
|
|
|
!call psb_barrier(icontxt)
|
|
|
|
|
|
|
|
|
|
if ((me==1).or.(me==2)) then
|
|
|
|
|
true = 1
|
|
|
|
|
else
|
|
|
|
|
true=0
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
@assertEqual(real(true*check),real(true*y(:,1)))
|
|
|
|
|
deallocate(vg,ia,val,y,v,check)
|
|
|
|
|
|
|
|
|
|
call psb_gefree(x, desc_a, info)
|
|
|
|
|
call psb_cdfree(desc_a, info)
|
|
|
|
|
|
|
|
|
|
call psb_exit(icontxt)
|
|
|
|
|
|
|
|
|
|
end subroutine test_psb_sswapdatam_2imgs
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end module test_psb_swapdata
|
|
|
|
|
|
