From 5dab2a7bcc74f86d12132f0763ecb5f8f6468147 Mon Sep 17 00:00:00 2001 From: Ambra Abdullahi Date: Tue, 2 May 2017 10:15:18 +0000 Subject: [PATCH] added test_psb_caf e test_psb_ihalo --- test/integrationTest/Makefile | 6 +- test/integrationTest/test_psb_caf.pf | 270 ++++++ test/integrationTest/test_psb_ihalo.pf | 1142 ++++++++++++++++++++++++ 3 files changed, 1415 insertions(+), 3 deletions(-) create mode 100644 test/integrationTest/test_psb_caf.pf create mode 100644 test/integrationTest/test_psb_ihalo.pf diff --git a/test/integrationTest/Makefile b/test/integrationTest/Makefile index 900a8d41..e62023e6 100644 --- a/test/integrationTest/Makefile +++ b/test/integrationTest/Makefile @@ -15,9 +15,9 @@ CCOPT= -g FINCLUDES=$(FMFLAG)$(INCDIR) $(FMFLAG). -all: prova +all: tests -prova.x: test_psb_dmatdist.o test_psb_ihalo.o test_psb_dhalo.o test_psb_shalo.o test_psb_chalo.o test_psb_zhalo.o test_psb_reduce_nrm2.o test_psb_sum.o test_psb_max.o test_psb_amx.o test_psb_min.o test_psb_amn.o test_psb_broadcast.o test_psb_caf.o driver.o +tests.x: test_psb_dmatdist.o test_psb_ihalo.o test_psb_dhalo.o test_psb_shalo.o test_psb_chalo.o test_psb_zhalo.o test_psb_reduce_nrm2.o test_psb_sum.o test_psb_max.o test_psb_amx.o test_psb_min.o test_psb_amn.o test_psb_broadcast.o test_psb_caf.o driver.o $(FCFLAGS)$(F90LINK) -g $(LOPT) -o $@ $^ -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -DUSE_CAF -lpfunit -lmpi %: %.x mpirun -np 8 ./$^ @@ -33,7 +33,7 @@ prova.x: test_psb_dmatdist.o test_psb_ihalo.o test_psb_dhalo.o test_psb_shalo.o clean: - /bin/rm -f *.F90 *.o *.mod + /bin/rm -f *.F90 *.o *.mod tests.x verycleanlib: (cd ../..; make veryclean) lib: diff --git a/test/integrationTest/test_psb_caf.pf b/test/integrationTest/test_psb_caf.pf new file mode 100644 index 00000000..39382697 --- /dev/null +++ b/test/integrationTest/test_psb_caf.pf @@ -0,0 +1,270 @@ +module test_psb_caf +use pfunit_mod +use psb_base_mod +use psb_caf_mod +implicit none +include 'mpif.h' + + +contains + + +@test(nimgs=[std]) +subroutine test_caf_allgather(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer:: ierr, status(MPI_STATUS_SIZE) + integer, parameter :: size_=10 + integer :: snd(size_) + integer, allocatable ::rcv(:,:),mpi_rcv(:,:) + integer ::np, me, info + + call MPI_COMM_RANK(MPI_COMM_WORLD, me, ierr) + me = this_image() + np=num_images() + allocate(rcv(size_,0:np)) + allocate(mpi_rcv(size_,0:np)) + rcv=me + mpi_rcv=me + snd = me - 1 + if (me == 1) then + snd(1:5)=(/1,32512,-1622251464,32512,62485/) + endif + if (me == 2) then + snd(1:5)=(/0,2,62488,62489,62490/) + endif + if (me == 3) then + snd(1:5)=(/2,3,0,0,0/) + endif + if (me == 4) then + snd(1:5)=(/2,62497,62498,62499,62500/) + endif + call caf_allgather(snd, size_, rcv, info) + call mpi_allgather(snd,size_,mpi_integer,& + & mpi_rcv,size_,mpi_integer,MPI_COMM_WORLD,ierr) + @assertEqual(mpi_rcv,rcv) + deallocate(rcv, mpi_rcv) +end subroutine test_caf_allgather + +@test(nimgs=[std]) +subroutine test_allgatherv(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + INTEGER::myrank, ierr, status(MPI_STATUS_SIZE), i + integer, allocatable ::snd(:), rcv(:),mpi_rcv(:), sdispls(:), rdispls(:), rcounts(:) + integer :: me, np, scounts + integer :: info + !call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr) + me=this_image() + np = num_images() + allocate(snd(2),rcv(np*6), mpi_rcv(np*6)) + allocate(sdispls(np), rcounts(np), rdispls(np)) + snd=me + rdispls(1)=0 + do i=1,np + if (MOD(i,2) == 0) then + rcounts(i)=2 + rdispls(i)=rdispls(i-1) + 2 + else + rcounts(i)=1 + if (i>1) rdispls(i)=rdispls(i-1) + 4 + endif + enddo + if (MOD(me,2)==1) then + scounts = 1 + else + scounts = 2 + endif + rcv=13 + mpi_rcv=13 + sync all + call caf_allgatherv(snd, scounts, rcv, rcounts, rdispls, info) + call mpi_allgatherv(snd, scounts, mpi_integer,& + & mpi_rcv,rcounts,rdispls,mpi_integer,MPI_COMM_WORLD,ierr) + + @assertEqual(mpi_rcv(1:size(rcv,1)),rcv) + deallocate(snd,rcv, mpi_rcv) + deallocate(sdispls, rcounts, rdispls) + +end subroutine test_allgatherv + +@test(nimgs=[std]) +subroutine test_allgatherv2(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + INTEGER::myrank, ierr, status(MPI_STATUS_SIZE), i + integer, allocatable ::snd(:), rcv(:),mpi_rcv(:), sdispls(:), rdispls(:), rcounts(:) + integer :: me, np, scounts + integer :: info + !call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr) + me=this_image() + np = num_images() + allocate(snd(2),rcv(np*3), mpi_rcv(np*3)) + allocate(sdispls(np), rcounts(np), rdispls(np)) + snd=me + rdispls(1)=0 + do i=1,np + if (MOD(i,2) == 0) then + rcounts(i)=2 + rdispls(i)=rdispls(i-1) + 1 + else + rcounts(i)=1 + if (i>1) rdispls(i)=rdispls(i-1) + 2 + endif + enddo + if (MOD(me,2)==1) then + scounts = 1 + else + scounts = 2 + endif + rcv=13 + mpi_rcv=13 + sync all + call caf_allgatherv(snd, scounts, rcv, rcounts, rdispls, info) + call mpi_allgatherv(snd, scounts, mpi_integer,& + & mpi_rcv,rcounts,rdispls,mpi_integer,MPI_COMM_WORLD,ierr) + @assertEqual(mpi_rcv(1:size(rcv,1)),rcv) + deallocate(snd,rcv, mpi_rcv) + deallocate(sdispls, rcounts, rdispls) +end subroutine test_allgatherv2 + +@test(nimgs=[std]) +subroutine test_alltoall(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + INTEGER::myrank, ierr, status(MPI_STATUS_SIZE) + integer :: size_ + integer, allocatable :: snd(:) + integer, allocatable ::rcv(:),mpi_rcv(:) + integer :: me, np + integer :: scount, info + !call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr) + me=this_image() + np = num_images() + if (allocated(snd)) deallocate(snd) + if (allocated(snd)) deallocate(rcv) + if (allocated(snd)) deallocate(mpi_rcv) + if (np >= 2) then + allocate(snd(np*2),rcv(np*2),mpi_rcv(np*2), STAT=ierr) + else + allocate(snd(4),rcv(4),mpi_rcv(4), STAT=ierr) + endif + snd=me + if (me==1) then + snd(1:4)=(/0,10,0,0/) + endif + if (me==2) then + snd(1:4)=(/10,0,10,0/) + endif + if (me==3) then + snd(1:4)=(/0,10,0,10/) + endif + if (me==1) then + snd(1:4)=(/0,0,10,0/) + endif + rcv=13 + mpi_rcv=13 + call caf_alltoall(snd, rcv, 1, info) + call mpi_alltoall(snd,1,mpi_integer,& + & mpi_rcv,1,mpi_integer,MPI_COMM_WORLD,ierr) + @assertEqual(mpi_rcv,rcv) + + if (allocated(snd)) deallocate(snd) + if (allocated(snd)) deallocate(rcv) + if (allocated(snd)) deallocate(mpi_rcv) +end subroutine test_alltoall + +@test(nimgs=[std]) +subroutine test_alltoallv(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + INTEGER::myrank, ierr, status(MPI_STATUS_SIZE), i + integer, allocatable ::snd(:), rcv(:),mpi_rcv(:), sdispls(:), scounts(:), rdispls(:), rcounts(:) + integer :: me, np + integer :: info + !call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr) + me=this_image() + np = num_images() + allocate(snd(np*2),rcv(np*2),mpi_rcv(np*2)) + allocate(scounts(np), sdispls(np), rcounts(np), rdispls(np)) + snd=me + if (MOD(me,2)==0) then + do i=1,np + rcounts(i)=1 + rdispls(i)=i-1 + enddo + else + do i=1,np + rcounts(i)=2 + rdispls(i)=(i-1)*2 + enddo + endif + sdispls(1)=0 + do i=1,np + if (MOD(i,2)==0) then + scounts(i) = 1 + sdispls(i)=sdispls(i-1) + 2 + else + scounts(i)=2 + if (i>1) sdispls(i)=sdispls(i-1) + 1 + endif + enddo + rcv=13 + mpi_rcv=13 + call caf_alltoallv(snd, scounts, sdispls, rcv, rcounts, rdispls, info) + call mpi_alltoallv(snd,scounts,sdispls, mpi_integer,& + & mpi_rcv,rcounts,rdispls,mpi_integer,MPI_COMM_WORLD,ierr) + @assertEqual(mpi_rcv,rcv) + +end subroutine test_alltoallv + +@test(nimgs=[std]) +subroutine test_dalltoallv(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + INTEGER::myrank, ierr, status(MPI_STATUS_SIZE), i + double precision, allocatable :: snd(:), rcv(:), mpi_rcv(:) + integer, allocatable :: sdispls(:), scounts(:), rdispls(:), rcounts(:) + integer :: me, np + integer :: info + !call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr) + me=this_image() + np = num_images() + allocate(snd(np*2),rcv(np*2),mpi_rcv(np*2)) + allocate(scounts(np), sdispls(np), rcounts(np), rdispls(np)) + snd=dble(me) + if (MOD(me,2)==0) then + do i=1,np + rcounts(i)=1 + rdispls(i)=i-1 + enddo + else + do i=1,np + rcounts(i)=2 + rdispls(i)=(i-1)*2 + enddo + endif + sdispls(1)=0 + do i=1,np + if (MOD(i,2)==0) then + scounts(i) = 1 + sdispls(i)=sdispls(i-1) + 2 + else + scounts(i)=2 + if (i>1) sdispls(i)=sdispls(i-1) + 1 + endif + enddo + rcv=dble(13) + mpi_rcv=dble(13) + call caf_dalltoallv(snd, scounts, sdispls, rcv, rcounts, rdispls, info) + call mpi_alltoallv(snd,scounts,sdispls, mpi_double,& + & mpi_rcv,rcounts,rdispls,mpi_double,MPI_COMM_WORLD,ierr) + @assertEqual(mpi_rcv,rcv) + +end subroutine test_dalltoallv +end module test_psb_caf diff --git a/test/integrationTest/test_psb_ihalo.pf b/test/integrationTest/test_psb_ihalo.pf new file mode 100644 index 00000000..6f835158 --- /dev/null +++ b/test/integrationTest/test_psb_ihalo.pf @@ -0,0 +1,1142 @@ +module test_psb_ihalo +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' +contains + +! A dense vector of size 6: [1 1 1 2 2 2]. 3rd and 4th entries (global) are halo indices. +! Before halo exchange: img1 [1 1 1 4] img2 [2 2 2 3] +! After halo exchange: img1 [1 1 1 2] img2 [2 2 2 1] +subroutine prepare_test2imgs(desc_a,x,check, np, icontxt, info) + use psb_base_mod + IMPLICIT NONE + type(psb_desc_type), intent(out):: desc_a + type(psb_i_vect_type), intent(out) :: x + integer, allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt, info + integer, intent(in) :: np + integer :: me, i=0, j + integer, parameter :: nrows=6 + integer :: mid, true + integer, allocatable :: vg(:), ia(:) + integer, allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + me = this_image() + info = 0 + if (np < 2) then + print*,'You need at least 2 processes to run this test.' + info = 1 + return + endif + call psb_init(icontxt,np,MPI_COMM_WORLD) + + !Allocate vectors + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + allocate(vg(nrows), STAT=info) + if (info == 0) allocate(ia(nrows), STAT=info) + if (info == 0) allocate(val(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + !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 (info /=0) then + print*,'ERROR in desc allocation', info + stop + endif + 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) + if (info /=0) then + print*,'ERROR in psb_cdins', info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', info + stop + endif + + + 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) + + sync all + + !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 + + !Let's build the expected solution + if (allocated(check)) deallocate(check) + if ((me == 1).or.(me==2)) then + allocate(check(mid+1), STAT=info) + else + allocate(check(1), STAT=info) + endif + if (info /=0) then + print*,'ERROR in allocating vectors', info + stop + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test2imgs + +! Before halo exchange: img1 [1 1 1, 4] img2 [2 2 2, 3] +! After halo exchange: img1 [1 1 2, 2] img2 [6 4 4, 1] +subroutine prepare_test2imgs_tran(desc_a,x,check, np, icontxt, info) + IMPLICIT NONE + type(psb_desc_type), intent(out):: desc_a + type(psb_i_vect_type), intent(out) :: x + integer(psb_ipk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt, info + integer, intent(in) :: np + integer :: me, i=0, j + integer, parameter :: nrows=6 + integer :: mid, true + integer, allocatable :: vg(:), ia(:) + integer(psb_ipk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + me = this_image() + info = 0 + if (np < 2) then + print*,'You need at least 2 processes to run this test.' + info = 1 + return + endif + call psb_init(icontxt,np,MPI_COMM_WORLD) + + !Allocate vectors + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + allocate(vg(nrows), STAT=info) + if (info == 0) allocate(ia(nrows), STAT=info) + if (info == 0) allocate(val(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + !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 (info /=0) then + print*,'ERROR in desc allocation', info + stop + endif + 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) + if (info /=0) then + print*,'ERROR in psb_cdins', info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', info + stop + endif + + + 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) + + sync all + + !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.0E0 + endif + + !Let's build the expected solution + if (allocated(check)) deallocate(check) + if ((me == 1).or.(me==2)) then + allocate(check(mid+1), STAT=info) + else + allocate(check(1), STAT=info) + endif + if (info /=0) then + print*,'ERROR in allocating vectors', info + stop + endif + + if (me == 1 ) then + check(1:mid-1)=1.0E0 + check(mid)=4.0E0 + check(mid + 1)=4.0E0 + else if (me == 2) then + check(1)=6.0E0 + check(mid-1:mid)=2.0E0 + check(mid + 1)=3.0E0 + else + check(1)=0.0E0 + endif + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test2imgs_tran + +subroutine prepare_test4imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_i_vect_type), intent(out) :: x + integer(psb_ipk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + integer(psb_ipk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + me = this_image() + info = 0 + if (np < 4) then + print*,'You need at least 4 processes to run this test.' + info = 1 + return + endif + call psb_init(icontxt,np,MPI_COMM_WORLD) + + !Allocate vectors + if (allocated(vg)) deallocate(vg) + allocate(vg(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + if (allocated(val)) deallocate(val) + allocate(val(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + !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 + + if (allocated(ia)) deallocate(ia) + if (allocated(ja)) deallocate(ja) + allocate(ia(nz),ja(nz), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + + 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 + if (allocated(check)) deallocate(check) + allocate (check(nz), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test4imgs + +subroutine prepare_test4imgs_tran(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_i_vect_type), intent(out) :: x + integer(psb_ipk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + integer(psb_ipk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + me = this_image() + info = 0 + if (np < 4) then + print*,'You need at least 4 processes to run this test.' + info = 1 + return + endif + call psb_init(icontxt,np,MPI_COMM_WORLD) + + !Allocate vectors + if (allocated(vg)) deallocate(vg) + allocate(vg(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + if (allocated(val)) deallocate(val) + allocate(val(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + !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 + + if (allocated(ia)) deallocate(ia) + if (allocated(ja)) deallocate(ja) + allocate(ia(nz),ja(nz), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + + 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 + if (allocated(check)) deallocate(check) + allocate (check(nz), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=6 + check(2)=12 + check(3)=4 + check(4)=4 + check(5)=6 + endif + if (me == 2) then + check(1)=24 + check(2)=40 + check(3)=4 + check(4)=4 + check(5)=12 + check(6)=12 + endif + if (me == 3) then + check(1)=60 + check(2)=54 + check(3)=6 + check(4)=12 + check(5)=12 + check(6)=24 + check(7)=24 + + endif + if (me == 4) then + check(1)=56 + check(2)=56 + check(3)=16 + check(4)=24 + check(5)=24 + endif + + ! END OF SETUP + + call psb_barrier(icontxt) + + !We can do something better here + x%v%v = x%v%v*2*me + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test4imgs_tran + +!HERE STARTS THE REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_ihalo_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test2imgs(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + call psb_halo(v, desc_a, info) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + deallocate(v,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_ihalo_tran_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test2imgs_tran(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + call psb_halo(v, desc_a, info, tran='T') + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + deallocate(v,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_tran_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_ihalo_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer, allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test2imgs(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + call psb_halo(x, desc_a, info) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + v = x%get_vect() + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + deallocate(v,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_ihalo_tran_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test2imgs_tran(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + call psb_halo(x, desc_a, info, tran='T') + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + v = x%get_vect() + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + deallocate(v,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_tran_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_ihalo_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test2imgs(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + allocate(m(size(v),1)) + m(:,1) = v + call psb_halo(m, desc_a, info) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + v = m(:,1) + @assertEqual(true*check,true*v) + deallocate(v,m,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_ihalo_tran_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test2imgs_tran(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + allocate(m(size(v),1)) + m(:,1) = v + call psb_halo(m, desc_a, info, tran='T') + v = m(:,1) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + + deallocate(v,m,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_tran_2imgs_m + + +@test(nimgs=[std]) +subroutine test_psb_ihalo_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test4imgs(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + call psb_halo(v, desc_a, info) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + if (allocated(v)) deallocate(v) + if (allocated(check)) deallocate(check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_ihalo_tran_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test4imgs_tran(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + call psb_halo(v, desc_a, info, tran='T') + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + if (allocated(v)) deallocate(v) + if (allocated(check)) deallocate(check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_tran_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_ihalo_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test4imgs(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + call psb_halo(x, desc_a, info) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + v = x%get_vect() + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + deallocate(v,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_ihalo_tran_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test4imgs_tran(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + call psb_halo(x, desc_a, info, tran='T') + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + v = x%get_vect() + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + deallocate(v,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_tran_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_ihalo_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test4imgs(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + allocate(m(size(v),1)) + m(:,1) = v + call psb_halo(m, desc_a, info) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + v = m(:,1) + @assertEqual(true*check,true*v) + deallocate(v,m,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_4imgs_m + +@test(nimgs=[std]) +subroutine test_psb_ihalo_tran_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + integer(psb_ipk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_i_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test4imgs_tran(desc_a,x,check, np, icontxt, info) + @assertEqual(0,info, "ERROR in preparing the test") + ! END OF SETUP + v = x%get_vect() + allocate(m(size(v),1)) + m(:,1) = v + call psb_halo(m, desc_a, info, tran='T') + v = m(:,1) + @assertEqual(0,info, "ERROR in psb_halo") + !GETTING BACK X + if ((me==1).or.(me==2)) then + true = 1 + else + true=0 + endif + @assertEqual(true*check,true*v) + + deallocate(v,m,check) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_ihalo_tran_4imgs_m + +end module test_psb_ihalo