From fc8e6c6895128f5d6123b3e60c04adde4210f4ef Mon Sep 17 00:00:00 2001 From: Ambra Abdullahi Date: Wed, 7 Dec 2016 16:08:10 +0000 Subject: [PATCH] added tests for halo exchange, dmat_dist, some of the collective subroutines --- test/integrationTest/Makefile | 6 +- test/integrationTest/Suites/testSuites.inc | 13 +- test/integrationTest/test_psb_amn.pf | 1052 +++++++ test/integrationTest/test_psb_amx.pf | 1053 +++++++ test/integrationTest/test_psb_broadcast.pf | 514 ++++ test/integrationTest/test_psb_chalo.pf | 2440 ++++++++++++++++ test/integrationTest/test_psb_dhalo.pf | 2436 ++++++++++++++++ test/integrationTest/test_psb_dmatdist.pf | 80 + test/integrationTest/test_psb_halo.pf | 2719 ++++++++++++++---- test/integrationTest/test_psb_max.pf | 651 +++++ test/integrationTest/test_psb_min.pf | 645 +++++ test/integrationTest/test_psb_reduce_nrm2.pf | 369 +++ test/integrationTest/test_psb_shalo.pf | 2436 ++++++++++++++++ test/integrationTest/test_psb_sum.pf | 1139 ++++++++ test/integrationTest/test_psb_zhalo.pf | 2440 ++++++++++++++++ 15 files changed, 17352 insertions(+), 641 deletions(-) create mode 100644 test/integrationTest/test_psb_amn.pf create mode 100644 test/integrationTest/test_psb_amx.pf create mode 100644 test/integrationTest/test_psb_broadcast.pf create mode 100644 test/integrationTest/test_psb_chalo.pf create mode 100644 test/integrationTest/test_psb_dhalo.pf create mode 100644 test/integrationTest/test_psb_dmatdist.pf create mode 100644 test/integrationTest/test_psb_max.pf create mode 100644 test/integrationTest/test_psb_min.pf create mode 100644 test/integrationTest/test_psb_reduce_nrm2.pf create mode 100644 test/integrationTest/test_psb_shalo.pf create mode 100644 test/integrationTest/test_psb_sum.pf create mode 100644 test/integrationTest/test_psb_zhalo.pf diff --git a/test/integrationTest/Makefile b/test/integrationTest/Makefile index 75ba2439..ece9c3d1 100644 --- a/test/integrationTest/Makefile +++ b/test/integrationTest/Makefile @@ -15,10 +15,12 @@ CCOPT= -g FINCLUDES=$(FMFLAG)$(INCDIR) $(FMFLAG). -all: test_psb_halo +all: prova +prova.x: test_psb_dmatdist.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 driver.o + $(FCFLAGS)$(F90LINK) -g $(LOPT) -o $@ $^ -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -DUSE_CAF -lpfunit -lmpi %: %.x - mpirun -np 4 ./$^ + mpirun -np 8 ./$^ %.x:%.o driver.o $(FCFLAGS)$(F90LINK) -g $(LOPT) -o $@ $^ -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -DUSE_CAF -lpfunit -lmpi #Create .F90 file diff --git a/test/integrationTest/Suites/testSuites.inc b/test/integrationTest/Suites/testSuites.inc index 1970c1f0..9eefe150 100644 --- a/test/integrationTest/Suites/testSuites.inc +++ b/test/integrationTest/Suites/testSuites.inc @@ -1 +1,12 @@ -ADD_TEST_SUITE(test_psb_halo_suite) +ADD_TEST_SUITE(test_psb_reduce_nrm2_suite) +ADD_TEST_SUITE(test_psb_max_suite) +ADD_TEST_SUITE(test_psb_amx_suite) +ADD_TEST_SUITE(test_psb_min_suite) +ADD_TEST_SUITE(test_psb_amn_suite) +ADD_TEST_SUITE(test_psb_sum_suite) +ADD_TEST_SUITE(test_psb_broadcast_suite) +ADD_TEST_SUITE(test_psb_dhalo_suite) +ADD_TEST_SUITE(test_psb_shalo_suite) +ADD_TEST_SUITE(test_psb_chalo_suite) +ADD_TEST_SUITE(test_psb_zhalo_suite) +ADD_TEST_SUITE(test_psb_dmatdist_suite) diff --git a/test/integrationTest/test_psb_amn.pf b/test/integrationTest/test_psb_amn.pf new file mode 100644 index 00000000..af3cfb60 --- /dev/null +++ b/test/integrationTest/test_psb_amn.pf @@ -0,0 +1,1052 @@ +module test_psb_amn +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_itest_s + module procedure prepare_stest_s + module procedure prepare_dtest_s + module procedure prepare_ctest_s + module procedure prepare_ztest_s + + module procedure prepare_itest_v + module procedure prepare_stest_v + module procedure prepare_dtest_v + module procedure prepare_ctest_v + module procedure prepare_ztest_v + + module procedure prepare_itest_m + module procedure prepare_stest_m + module procedure prepare_dtest_m + module procedure prepare_ctest_m + module procedure prepare_ztest_m +end interface prepare_test + +interface prepare_test2 + module procedure prepare_itest2_s + module procedure prepare_stest2_s + module procedure prepare_dtest2_s + module procedure prepare_ctest2_s + module procedure prepare_ztest2_s + + module procedure prepare_itest2_v + module procedure prepare_stest2_v + module procedure prepare_dtest2_v + module procedure prepare_ctest2_v + module procedure prepare_ztest2_v + + module procedure prepare_itest2_m + module procedure prepare_stest2_m + module procedure prepare_dtest2_m + module procedure prepare_ctest2_m + module procedure prepare_ztest2_m +end interface prepare_test2 + +contains + + subroutine prepare_itest_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check = dat + if (me == root + 1) then + check=-1 + endif + end subroutine prepare_itest_s + + subroutine prepare_stest_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image()) + check = dat + if (me == root + 1) then + check=-real(1) + endif + end subroutine prepare_stest_s + + subroutine prepare_dtest_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image()) + check = dat + if (me == root + 1) then + check=-dble(1) + endif + end subroutine prepare_dtest_s + + subroutine prepare_ctest_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check = dat + if (me == root + 1) then + check=-complex(1,1)/(np) + endif + end subroutine prepare_ctest_s + + subroutine prepare_ztest_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check = dat + if (me == root + 1) then + check=-complex(1,1)/(np) + endif + end subroutine prepare_ztest_s + + + subroutine prepare_itest_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check = dat + if (me == root + 1) then + check=-1 + endif + end subroutine prepare_itest_v + + subroutine prepare_stest_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image()) + check = dat + if (me == root + 1) then + check=-real(1) + endif + end subroutine prepare_stest_v + + subroutine prepare_dtest_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image()) + check = dat + if (me == root + 1) then + check=-dble(1) + endif + end subroutine prepare_dtest_v + + subroutine prepare_ctest_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check = dat + if (me == root + 1) then + check=-complex(1,1)/(np) + endif + end subroutine prepare_ctest_v + + subroutine prepare_ztest_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check = dat + if (me == root + 1) then + check=-complex(1,1)/(np) + endif + end subroutine prepare_ztest_v + + + subroutine prepare_itest_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check = dat + if (me == root + 1) then + check=-1 + endif + end subroutine prepare_itest_m + + subroutine prepare_stest_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image()) + check = dat + if (me == root + 1) then + check=-real(1) + endif + end subroutine prepare_stest_m + + subroutine prepare_dtest_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image()) + check = dat + if (me == root + 1) then + check=-dble(1) + endif + end subroutine prepare_dtest_m + + subroutine prepare_ctest_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check = dat + if (me == root + 1) then + check=-complex(1,1)/(np) + endif + end subroutine prepare_ctest_m + + subroutine prepare_ztest_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check = dat + if (me == root + 1) then + check=-complex(1,1)/(np) + endif + end subroutine prepare_ztest_m + + subroutine prepare_itest2_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check=-1 + end subroutine prepare_itest2_s + + subroutine prepare_stest2_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image()) + check=-real(1) + end subroutine prepare_stest2_s + + subroutine prepare_dtest2_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image()) + check=-dble(1) + end subroutine prepare_dtest2_s + + subroutine prepare_ctest2_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check=-complex(1,1)/(np) + end subroutine prepare_ctest2_s + + subroutine prepare_ztest2_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check=-complex(1,1)/(np) + end subroutine prepare_ztest2_s + + + subroutine prepare_itest2_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check=-1 + end subroutine prepare_itest2_v + + subroutine prepare_stest2_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image()) + check=-real(1) + end subroutine prepare_stest2_v + + subroutine prepare_dtest2_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image()) + check=-dble(1) + end subroutine prepare_dtest2_v + + subroutine prepare_ctest2_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check=-complex(1,1)/(np) + end subroutine prepare_ctest2_v + + subroutine prepare_ztest2_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check=-complex(1,1)/(np) + end subroutine prepare_ztest2_v + + + subroutine prepare_itest2_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check=-1 + end subroutine prepare_itest2_m + + subroutine prepare_stest2_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image()) + check=-real(1) + end subroutine prepare_stest2_m + + subroutine prepare_dtest2_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image()) + check=-dble(1) + end subroutine prepare_dtest2_m + + subroutine prepare_ctest2_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check=-complex(1,1)/(np) + end subroutine prepare_ctest2_m + + subroutine prepare_ztest2_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np) + check=-complex(1,1)/(np) + end subroutine prepare_ztest2_m +!--------- REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_iamn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_iamn_s + +@test(nimgs=[std]) +subroutine test_psb_samn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_samn_s + +@test(nimgs=[std]) +subroutine test_psb_damn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_damn_s + +@test(nimgs=[std]) +subroutine test_psb_camn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_camn_s + +@test(nimgs=[std]) +subroutine test_psb_zamn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_zamn_s + + +@test(nimgs=[std]) +subroutine test_psb_iamn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_iamn_v + +@test(nimgs=[std]) +subroutine test_psb_samn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_samn_v + +@test(nimgs=[std]) +subroutine test_psb_damn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_damn_v + +@test(nimgs=[std]) +subroutine test_psb_camn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_camn_v + +@test(nimgs=[std]) +subroutine test_psb_zamn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_zamn_v + + +@test(nimgs=[std]) +subroutine test_psb_iamn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_iamn_m + +@test(nimgs=[std]) +subroutine test_psb_samn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_samn_m + +@test(nimgs=[std]) +subroutine test_psb_damn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_damn_m + +@test(nimgs=[std]) +subroutine test_psb_camn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_camn_m + +@test(nimgs=[std]) +subroutine test_psb_zamn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_zamn_m + +@test(nimgs=[std]) +subroutine test2_psb_iamn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_iamn_s + +@test(nimgs=[std]) +subroutine test2_psb_samn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_samn_s + +@test(nimgs=[std]) +subroutine test2_psb_damn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_damn_s + +@test(nimgs=[std]) +subroutine test2_psb_camn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_camn_s + +@test(nimgs=[std]) +subroutine test2_psb_zamn_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_zamn_s + + +@test(nimgs=[std]) +subroutine test2_psb_iamn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_iamn_v + +@test(nimgs=[std]) +subroutine test2_psb_samn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_samn_v + +@test(nimgs=[std]) +subroutine test2_psb_damn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_damn_v + +@test(nimgs=[std]) +subroutine test2_psb_camn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_camn_v + +@test(nimgs=[std]) +subroutine test2_psb_zamn_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_zamn_v + + +@test(nimgs=[std]) +subroutine test2_psb_iamn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_iamn_m + +@test(nimgs=[std]) +subroutine test2_psb_samn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_samn_m + +@test(nimgs=[std]) +subroutine test2_psb_damn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_damn_m + +@test(nimgs=[std]) +subroutine test2_psb_camn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_camn_m + +@test(nimgs=[std]) +subroutine test2_psb_zamn_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amn(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_zamn_m + +end module test_psb_amn diff --git a/test/integrationTest/test_psb_amx.pf b/test/integrationTest/test_psb_amx.pf new file mode 100644 index 00000000..c0073322 --- /dev/null +++ b/test/integrationTest/test_psb_amx.pf @@ -0,0 +1,1053 @@ +module test_psb_amx +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_itest_s + module procedure prepare_stest_s + module procedure prepare_dtest_s + module procedure prepare_ctest_s + module procedure prepare_ztest_s + + module procedure prepare_itest_v + module procedure prepare_stest_v + module procedure prepare_dtest_v + module procedure prepare_ctest_v + module procedure prepare_ztest_v + + module procedure prepare_itest_m + module procedure prepare_stest_m + module procedure prepare_dtest_m + module procedure prepare_ctest_m + module procedure prepare_ztest_m +end interface prepare_test + +interface prepare_test2 + module procedure prepare_itest2_s + module procedure prepare_stest2_s + module procedure prepare_dtest2_s + module procedure prepare_ctest2_s + module procedure prepare_ztest2_s + + module procedure prepare_itest2_v + module procedure prepare_stest2_v + module procedure prepare_dtest2_v + module procedure prepare_ctest2_v + module procedure prepare_ztest2_v + + module procedure prepare_itest2_m + module procedure prepare_stest2_m + module procedure prepare_dtest2_m + module procedure prepare_ctest2_m + module procedure prepare_ztest2_m +end interface prepare_test2 + +contains + + subroutine prepare_itest_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check = dat + if (me == root + 1) then + check=-np + endif + end subroutine prepare_itest_s + + subroutine prepare_stest_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image())/real(np+1) + check = dat + if (me == root + 1) then + check=-real(np)/real(np+1) + endif + end subroutine prepare_stest_s + + subroutine prepare_dtest_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image())/dble(np+1) + check = dat + if (me == root + 1) then + check=-dble(np)/dble(np+1) + endif + end subroutine prepare_dtest_s + + subroutine prepare_ctest_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check = dat + if (me == root + 1) then + check=-complex(np,np)/(np+1) + endif + end subroutine prepare_ctest_s + + subroutine prepare_ztest_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check = dat + if (me == root + 1) then + check=-complex(np,np)/(np+1) + endif + end subroutine prepare_ztest_s + + + subroutine prepare_itest_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check = dat + if (me == root + 1) then + check=-np + endif + end subroutine prepare_itest_v + + subroutine prepare_stest_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image())/real(np+1) + check = dat + if (me == root + 1) then + check=-real(np)/real(np+1) + endif + end subroutine prepare_stest_v + + subroutine prepare_dtest_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image())/dble(np+1) + check = dat + if (me == root + 1) then + check=-dble(np)/dble(np+1) + endif + end subroutine prepare_dtest_v + + subroutine prepare_ctest_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check = dat + if (me == root + 1) then + check=-complex(np,np)/(np+1) + endif + end subroutine prepare_ctest_v + + subroutine prepare_ztest_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check = dat + if (me == root + 1) then + check=-complex(np,np)/(np+1) + endif + end subroutine prepare_ztest_v + + + subroutine prepare_itest_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check = dat + if (me == root + 1) then + check=-np + endif + end subroutine prepare_itest_m + + subroutine prepare_stest_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image())/real(np+1) + check = dat + if (me == root + 1) then + check=-real(np)/real(np+1) + endif + end subroutine prepare_stest_m + + subroutine prepare_dtest_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image())/dble(np+1) + check = dat + if (me == root + 1) then + check=-dble(np)/dble(np+1) + endif + end subroutine prepare_dtest_m + + subroutine prepare_ctest_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check = dat + if (me == root + 1) then + check=-complex(np,np)/(np+1) + endif + end subroutine prepare_ctest_m + + subroutine prepare_ztest_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check = dat + if (me == root + 1) then + check=-complex(np,np)/(np+1) + endif + end subroutine prepare_ztest_m + + subroutine prepare_itest2_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check=-np + end subroutine prepare_itest2_s + + subroutine prepare_stest2_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image())/real(np+1) + check=-real(np)/real(np+1) + end subroutine prepare_stest2_s + + subroutine prepare_dtest2_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image())/dble(np+1) + check=-dble(np)/dble(np+1) + end subroutine prepare_dtest2_s + + subroutine prepare_ctest2_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check=-complex(np,np)/(np+1) + end subroutine prepare_ctest2_s + + subroutine prepare_ztest2_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check=-complex(np,np)/(np+1) + end subroutine prepare_ztest2_s + + + subroutine prepare_itest2_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check=-np + end subroutine prepare_itest2_v + + subroutine prepare_stest2_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image())/real(np+1) + check=-real(np)/real(np+1) + end subroutine prepare_stest2_v + + subroutine prepare_dtest2_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image())/dble(np+1) + check=-dble(np)/dble(np+1) + end subroutine prepare_dtest2_v + + subroutine prepare_ctest2_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check=-complex(np,np)/(np+1) + end subroutine prepare_ctest2_v + + subroutine prepare_ztest2_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check=-complex(np,np)/(np+1) + end subroutine prepare_ztest2_v + + + subroutine prepare_itest2_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -this_image() + check=-np + end subroutine prepare_itest2_m + + subroutine prepare_stest2_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -real(this_image())/real(np+1) + check=-real(np)/real(np+1) + end subroutine prepare_stest2_m + + subroutine prepare_dtest2_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -dble(this_image())/dble(np+1) + check=-dble(np)/dble(np+1) + end subroutine prepare_dtest2_m + + subroutine prepare_ctest2_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check=-complex(np,np)/(np+1) + end subroutine prepare_ctest2_m + + subroutine prepare_ztest2_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = -complex(this_image(),this_image())/(np+1) + check=-complex(np,np)/(np+1) + end subroutine prepare_ztest2_m + +!--------- REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_iamx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_iamx_s + +@test(nimgs=[std]) +subroutine test_psb_samx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_samx_s + +@test(nimgs=[std]) +subroutine test_psb_damx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_damx_s + +@test(nimgs=[std]) +subroutine test_psb_camx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_camx_s + +@test(nimgs=[std]) +subroutine test_psb_zamx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_zamx_s + + +@test(nimgs=[std]) +subroutine test_psb_iamx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_iamx_v + +@test(nimgs=[std]) +subroutine test_psb_samx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_samx_v + +@test(nimgs=[std]) +subroutine test_psb_damx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_damx_v + +@test(nimgs=[std]) +subroutine test_psb_camx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_camx_v + +@test(nimgs=[std]) +subroutine test_psb_zamx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_zamx_v + + +@test(nimgs=[std]) +subroutine test_psb_iamx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_iamx_m + +@test(nimgs=[std]) +subroutine test_psb_samx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_samx_m + +@test(nimgs=[std]) +subroutine test_psb_damx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_damx_m + +@test(nimgs=[std]) +subroutine test_psb_camx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_camx_m + +@test(nimgs=[std]) +subroutine test_psb_zamx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_zamx_m + +@test(nimgs=[std]) +subroutine test2_psb_iamx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_iamx_s + +@test(nimgs=[std]) +subroutine test2_psb_samx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_samx_s + +@test(nimgs=[std]) +subroutine test2_psb_damx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_damx_s + +@test(nimgs=[std]) +subroutine test2_psb_camx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_camx_s + +@test(nimgs=[std]) +subroutine test2_psb_zamx_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_zamx_s + + +@test(nimgs=[std]) +subroutine test2_psb_iamx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_iamx_v + +@test(nimgs=[std]) +subroutine test2_psb_samx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_samx_v + +@test(nimgs=[std]) +subroutine test2_psb_damx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_damx_v + +@test(nimgs=[std]) +subroutine test2_psb_camx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_camx_v + +@test(nimgs=[std]) +subroutine test2_psb_zamx_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_zamx_v + + +@test(nimgs=[std]) +subroutine test2_psb_iamx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_iamx_m + +@test(nimgs=[std]) +subroutine test2_psb_samx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_samx_m + +@test(nimgs=[std]) +subroutine test2_psb_damx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_damx_m + +@test(nimgs=[std]) +subroutine test2_psb_camx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_camx_m + +@test(nimgs=[std]) +subroutine test2_psb_zamx_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_amx(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_zamx_m + +end module test_psb_amx diff --git a/test/integrationTest/test_psb_broadcast.pf b/test/integrationTest/test_psb_broadcast.pf new file mode 100644 index 00000000..aa6152ef --- /dev/null +++ b/test/integrationTest/test_psb_broadcast.pf @@ -0,0 +1,514 @@ +module test_psb_broadcast +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_itest_s + module procedure prepare_stest_s + module procedure prepare_dtest_s + module procedure prepare_ctest_s + module procedure prepare_ztest_s + + module procedure prepare_itest_v + module procedure prepare_stest_v + module procedure prepare_dtest_v + module procedure prepare_ctest_v + module procedure prepare_ztest_v + + module procedure prepare_itest_m + module procedure prepare_stest_m + module procedure prepare_dtest_m + module procedure prepare_ctest_m + module procedure prepare_ztest_m +end interface prepare_test + +contains + + subroutine prepare_itest_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check=root + 1 + end subroutine prepare_itest_s + + subroutine prepare_stest_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check=real(root + 1) + end subroutine prepare_stest_s + + subroutine prepare_dtest_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check=dble(root + 1) + end subroutine prepare_dtest_s + + subroutine prepare_ctest_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check=complex(root + 1, root + 1) + end subroutine prepare_ctest_s + + subroutine prepare_ztest_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check=complex(root + 1, root + 1) + end subroutine prepare_ztest_s + + + subroutine prepare_itest_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check=root + 1 + end subroutine prepare_itest_v + + subroutine prepare_stest_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check=real(root + 1) + end subroutine prepare_stest_v + + subroutine prepare_dtest_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check=dble(root + 1) + end subroutine prepare_dtest_v + + subroutine prepare_ctest_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check=complex(root + 1, root + 1) + end subroutine prepare_ctest_v + + subroutine prepare_ztest_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check=complex(root + 1, root + 1) + end subroutine prepare_ztest_v + + subroutine prepare_itest_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check=root + 1 + end subroutine prepare_itest_m + + subroutine prepare_stest_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check=real(root + 1) + end subroutine prepare_stest_m + + subroutine prepare_dtest_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check=dble(root + 1) + end subroutine prepare_dtest_m + + subroutine prepare_ctest_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check=complex(root + 1,root + 1) + end subroutine prepare_ctest_m + + subroutine prepare_ztest_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer, parameter :: size_=23 + integer :: me + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check=complex(root + 1,root + 1) + end subroutine prepare_ztest_m + +!--------- REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_ibroadcast_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + +end subroutine test_psb_ibroadcast_s + +@test(nimgs=[std]) +subroutine test_psb_sbroadcast_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + +end subroutine test_psb_sbroadcast_s + +@test(nimgs=[std]) +subroutine test_psb_dbroadcast_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + print*,'from test:', this_image(), dat + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + +end subroutine test_psb_dbroadcast_s + +@test(nimgs=[std]) +subroutine test_psb_cbroadcast_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + +end subroutine test_psb_cbroadcast_s + +@test(nimgs=[std]) +subroutine test_psb_zbroadcast_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + +end subroutine test_psb_zbroadcast_s + +@test(nimgs=[std]) +subroutine test_psb_ibroadcast_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_ibroadcast_v + +@test(nimgs=[std]) +subroutine test_psb_sbroadcast_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_sbroadcast_v + +@test(nimgs=[std]) +subroutine test_psb_dbroadcast_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_dbroadcast_v + + +@test(nimgs=[std]) +subroutine test_psb_cbroadcast_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_cbroadcast_v + +@test(nimgs=[std]) +subroutine test_psb_zbroadcast_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_zbroadcast_v + +@test(nimgs=[std]) +subroutine test_psb_ibroadcast_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_ibroadcast_m + +@test(nimgs=[std]) +subroutine test_psb_sbroadcast_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_sbroadcast_m + +@test(nimgs=[std]) +subroutine test_psb_dbroadcast_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_dbroadcast_m + +@test(nimgs=[std]) +subroutine test_psb_cbroadcast_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_cbroadcast_m + +@test(nimgs=[std]) +subroutine test_psb_zbroadcast_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_bcast(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) + deallocate(dat, check) +end subroutine test_psb_zbroadcast_m + +end module test_psb_broadcast diff --git a/test/integrationTest/test_psb_chalo.pf b/test/integrationTest/test_psb_chalo.pf new file mode 100644 index 00000000..0210f991 --- /dev/null +++ b/test/integrationTest/test_psb_chalo.pf @@ -0,0 +1,2440 @@ +module test_psb_chalo +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_c_vect_type), intent(out) :: x + complex(psb_spk_), 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(:) + complex(psb_spk_), 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.0E0,1.0E0) + enddo + + do i=mid + 1,nrows + val(i)=(2.0E0,2.0E0) + 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,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.0E0,1.0E0) + check(mid + 1)=(2.0E0,2.0E0) + else if (me == 2) then + check(1:mid)=(2.0E0,2.0E0) + check(mid + 1)=(1.0E0,1.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 + +! 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_c_vect_type), intent(out) :: x + complex(psb_spk_), 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(:) + complex(psb_spk_), 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.0E0,1.0E0) + enddo + + do i=mid + 1,nrows + val(i)=(2.0E0,2.0E0) + 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,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,1.0E0) + check(mid)=(4.0E0,4.0E0) + check(mid + 1)=(4.0E0,4.0E0) + else if (me == 2) then + check(1)=(6.0E0,6.0E0) + check(mid-1:mid)=(2.0E0,2.0E0) + check(mid + 1)=(3.0E0,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_c_vect_type), intent(out) :: x + complex(psb_spk_), 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(:) + complex(psb_spk_), 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.0E0,1.0E0) + enddo + do i= mid + 1, 2*mid + val(i)=(2.0E0,2.0E0) + enddo + do i=2*mid + 1, 3*mid + val(i)=(3.0E0,3.0E0) + enddo + do i=3*mid + 1, nrows + val(i)=(4.0E0,4.0E0) + 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.0E0,2.0E0) + check(2)=(2.0E0,2.0E0) + check(3)=(8.0E0,8.0E0) + check(4)=(8.0E0,8.0E0) + check(5)=(18.0E0,18.0E0) + endif + if (me == 2) then + check(1)=(8.0E0,8.0E0) + check(2)=(8.0E0,8.0E0) + check(3)=(2.0E0,2.0E0) + check(4)=(2.0E0,2.0E0) + check(5)=(18.0E0,18.0E0) + check(6)=(18.0E0,18.0E0) + endif + if (me == 3) then + check(1)=(18.0E0,18.0E0) + check(2)=(18.0E0,18.0E0) + check(3)=(1.0E0,1.0E0) + check(4)=(8.0E0,8.0E0) + check(5)=(8.0E0,8.0E0) + check(6)=(32.0E0,32.0E0) + check(7)=(32.0E0,32.0E0) + + endif + if (me == 4) then + check(1)=(32.0E0,32.0E0) + check(2)=(32.0E0,32.0E0) + check(3)=(8.0E0,8.0E0) + check(4)=(18.0E0,18.0E0) + check(5)=(18.0E0,18.0E0) + 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_c_vect_type), intent(out) :: x + complex(psb_spk_), 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(:) + complex(psb_spk_), 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.0E0,1.0E0) + enddo + do i= mid + 1, 2*mid + val(i)=(2.0E0,2.0E0) + enddo + do i=2*mid + 1, 3*mid + val(i)=(3.0E0,3.0E0) + enddo + do i=3*mid + 1, nrows + val(i)=(4.0E0,4.0E0) + 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.0E0,6.0E0) + check(2)=(12.0E0,12.0E0) + check(3)=(4.0E0,4.0E0) + check(4)=(4.0E0,4.0E0) + check(5)=(6.0E0,6.0E0) + endif + if (me == 2) then + check(1)=(24.0E0,24.0E0) + check(2)=(40.0E0,40.0E0) + check(3)=(4.0E0,4.0E0) + check(4)=(4.0E0,4.0E0) + check(5)=(12.0E0,12.0E0) + check(6)=(12.0E0,12.0E0) + endif + if (me == 3) then + check(1)=(6.0E0,6.0E0) + check(2)=(54.0E0,54.0E0) + check(3)=(6.0E0,6.0E0) + check(4)=(12.0E0,12.0E0) + check(5)=(12.0E0,12.0E0) + check(6)=(24.0E0,24.0E0) + check(7)=(24.0E0,24.0E0) + + endif + if (me == 4) then + check(1)=(56.0E0,65.0E0) + check(2)=(56.0E0,65.0E0) + check(3)=(16.0E0,16.0E0) + check(4)=(24.0E0,24.0E0) + check(5)=(24.0E0,24.0E0) + 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 + +subroutine prepare_test8imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_c_vect_type), intent(out) :: x + complex(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,me) + enddo + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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.0E0,2.0E0) + check(2)=(12.0E0,12.0E0) + endif + if (me == 2) then + check(1)=(4.0E0,4.0E0) + check(2)=(2.0E0,2.0E0) + check(3)=(14.0E0,14.0E0) + endif + if (me == 3) then + check(1)=(6.0E0,6.0E0) + check(2)=(2.0E0,2.0E0) + check(3)=(4.0E0,4.0E0) + check(4)=(16.0E0,16.0E0) + + endif + if (me == 4) then + check(1)=(8.0E0,8.0E0) + check(2)=(4.0E0,4.0E0) + check(3)=(6.0E0,6.0E0) + endif + if (me == 5) then + check(1)=(10.0E0,10.0E0) + + check(2)=(6.0E0,6.0E0) + check(3)=(8.0E0,8.0E0) + endif + if (me == 6) then + check(1)=(12.0E0,12.0E0) + check(2)=(8.0E0,8.0E0) + check(3)=(10.0E0,10.0E0) + endif + if (me == 7) then + check(1)=(14.0E0,14.0E0) + + check(2)=(10.0E0,10.0E0) + check(3)=(12.0E0,12.0E0) + endif + if (me == 8) then + check(1)=(16.0E0,16.0E0) + check(2)=(12.0E0,12.0E0) + check(3)=(14.0E0,14.0E0) + endif + if (me > 8) then + check(1)=(0.0E0,0.0E0) + endif + ! END OF SETUP + + + + call psb_barrier(icontxt) + !We can do something better here + x%v%v = x%v%v + cmplx(me,me) + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs + +subroutine prepare_test8imgs_tran(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_c_vect_type), intent(out) :: x + complex(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,me) + enddo + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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)=(9.0E0,9.0E0) + check(2)=(7.0E0,7.0E0) + endif + if (me == 2) then + check(1)=(15.0E0,15.0E0) + check(2)=(3.0E0,3.0E0) + check(3)=(9.0E0,9.0E0) + endif + if (me == 3) then + check(1)=(21.0E0,21.0E0) + check(2)=(4.0E0,4.0E0) + check(3)=(5.0E0,5.0E0) + check(4)=(11.0E0,11.0E0) + + endif + if (me == 4) then + check(1)=(27.0E0,27.0E0) + check(2)=(6.0E0,6.0E0) + check(3)=(7.0E0,7.0E0) + endif + if (me == 5) then + check(1)=(33.0E0,33.0E0) + check(2)=(8.0E0,8.0E0) + check(3)=(9.0E0,9.0E0) + endif + if (me == 6) then + check(1)=(46.0E0,46.0E0) + check(2)=(10.0E0,10.0E0) + check(3)=(13.0E0,13.0E0) + endif + if (me == 7) then + check(1)=(38.0E0,38.0E0) + check(2)=(12.0E0,12.0E0) + check(3)=(13.0E0,13.0E0) + endif + if (me == 8) then + check(1)=(27.0E0,27.0E0) + check(2)=(14.0E0,14.0E0) + check(3)=(15.0E0,15.0E0) + 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 + cmplx(me,me) + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs_tran + +subroutine prepare_test8imgs_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_c_vect_type), intent(out) :: x + complex(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=(2.0E0,2.0E0) + check(2)=(4.0E0,4.0E0) + check(3)=(6.0E0,6.0E0) + check(4)=(8.0E0,8.0E0) + check(5)=(10.0E0,10.0E0) + check(6)=(12.0E0,12.0E0) + check(7)=(14.0E0,14.0E0) + check(8)=(16.0E0,16.0E0) + endif + if (me == 2) then + check(1)=(4.0E0,4.0E0) + check(2)=(2.0E0,2.0E0) + endif + if (me == 3) then + check(1)=(6.0E0,6.0E0) + check(2)=(2.0E0,2.0E0) + + endif + if (me == 4) then + check(1)=(8.0E0,8.0E0) + check(2)=(2.0E0,2.0E0) + endif + if (me == 5) then + check(1)=(10.0E0,10.0E0) + + check(2)=(2.0E0,2.0E0) + endif + if (me == 6) then + check(1)=(12.0E0,12.0E0) + check(2)=(2.0E0,2.0E0) + endif + if (me == 7) then + check(1)=(14.0E0,14.0E0) + + check(2)=(2.0E0,2.0E0) + endif + if (me == 8) then + check(1)=(16.0E0,16.0E0) + check(2)=(2.0E0,2.0E0) + 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 + cmplx(me,me) + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_b + + +subroutine prepare_test8imgs_tran_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_c_vect_type), intent(out) :: x + complex(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=(44.0E0,44.0E0) + check(2)=(3.0E0,3.0E0) + check(3)=(4.0E0,4.0E0) + check(4)=(5.0E0,5.0E0) + check(5)=(6.0E0,6.0E0) + check(6)=(7.0E0,7.0E0) + check(7)=(8.0E0,8.0E0) + check(8)=(9.0E0,9.0E0) + endif + if (me == 2) then + check(1)=(7.0E0,7.0E0) + check(2)=(3.0E0,3.0E0) + endif + if (me == 3) then + check(1)=(10.0E0,10.0E0) + check(2)=(4.0E0,4.0E0) + + endif + if (me == 4) then + check(1)=(13.0E0,13.0E0) + check(2)=(5.0E0,5.0E0) + endif + if (me == 5) then + check(1)=(16.0E0,16.0E0) + check(2)=(6.0E0,6.0E0) + endif + if (me == 6) then + check(1)=(19.0E0,19.0E0) + check(2)=(7.0E0,7.0E0) + endif + if (me == 7) then + check(1)=(22.0E0,22.0E0) + check(2)=(8.0E0,8.0E0) + endif + if (me == 8) then + check(1)=(25.0E0,25.0E0) + check(2)=(9.0E0,9.0E0) + 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 + cmplx(me,me) + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_tran_b + +@test(nimgs=[std]) +subroutine test_psb_chalo_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_tran_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_chalo_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_tran_2imgs_vect + + +@test(nimgs=[std]) +subroutine test_psb_chalo_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_tran_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_chalo_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_tran_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_chalo_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_tran_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_chalo_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_4imgs_m + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_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_chalo_tran_4imgs_m + + +@test(nimgs=[std]) +subroutine test_psb_chalo_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_chalo_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_chalo_tran_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_chalo_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_chalo_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_chalo_tran_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_chalo_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_chalo_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_chalo_tran_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_chalo_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_chalo_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_chalo_tran_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_chalo_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_chalo_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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() + + PRINT*,'-------', ME, V + 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_chalo_tran_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_chalo_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_chalo_8imgs_m_b + +@test(nimgs=[std]) +subroutine test_psb_chalo_tran_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_chalo_tran_8imgs_m_b + +end module test_psb_chalo + diff --git a/test/integrationTest/test_psb_dhalo.pf b/test/integrationTest/test_psb_dhalo.pf new file mode 100644 index 00000000..a0137b6a --- /dev/null +++ b/test/integrationTest/test_psb_dhalo.pf @@ -0,0 +1,2436 @@ +module test_psb_dhalo +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_d_vect_type), intent(out) :: x + real(psb_dpk_), 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(:) + real(psb_dpk_), 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_d_vect_type), intent(out) :: x + real(psb_dpk_), 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(:) + real(psb_dpk_), 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)=1.0d0 + check(mid)=4.0d0 + check(mid + 1)=4.0d0 + else if (me == 2) then + check(1)=6.0d0 + check(mid-1:mid)=2.0d0 + check(mid + 1)=3.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_tran + + +subroutine prepare_test4imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), 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(:) + real(psb_dpk_), 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_d_vect_type), intent(out) :: x + real(psb_dpk_), 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(:) + real(psb_dpk_), 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 + +subroutine prepare_test8imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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 + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs + +subroutine prepare_test8imgs_tran(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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 + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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)=9 + check(2)=7 + endif + if (me == 2) then + check(1)=15 + check(2)=3 + check(3)=9 + endif + if (me == 3) then + check(1)=21 + check(2)=4 + check(3)=5 + check(4)=11 + + endif + if (me == 4) then + check(1)=27 + check(2)=6 + check(3)=7 + endif + if (me == 5) then + check(1)=33 + check(2)=8 + check(3)=9 + endif + if (me == 6) then + check(1)=46 + check(2)=10 + check(3)=13 + endif + if (me == 7) then + check(1)=38 + check(2)=12 + check(3)=13 + endif + if (me == 8) then + check(1)=27 + check(2)=14 + check(3)=15 + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs_tran + +subroutine prepare_test8imgs_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), 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)=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 + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_b + + +subroutine prepare_test8imgs_tran_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=44 + check(2)=3 + check(3)=4 + check(4)=5 + check(5)=6 + check(6)=7 + check(7)=8 + check(8)=9 + endif + if (me == 2) then + check(1)=7 + check(2)=3 + endif + if (me == 3) then + check(1)=10 + check(2)=4 + + endif + if (me == 4) then + check(1)=13 + check(2)=5 + endif + if (me == 5) then + check(1)=16 + check(2)=6 + endif + if (me == 6) then + check(1)=19 + check(2)=7 + endif + if (me == 7) then + check(1)=22 + check(2)=8 + endif + if (me == 8) then + check(1)=25 + check(2)=9 + 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 + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_tran_b + +@test(nimgs=[std]) +subroutine test_psb_dhalo_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_tran_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_dhalo_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_tran_2imgs_vect + + +@test(nimgs=[std]) +subroutine test_psb_dhalo_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_tran_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_dhalo_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_tran_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_dhalo_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_tran_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_dhalo_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_4imgs_m + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_dhalo_tran_4imgs_m + + +@test(nimgs=[std]) +subroutine test_psb_dhalo_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_dhalo_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_dhalo_tran_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_dhalo_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_dhalo_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_dhalo_tran_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_dhalo_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_dhalo_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_dhalo_tran_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_dhalo_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_dhalo_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_dhalo_tran_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_dhalo_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_dhalo_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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() + + PRINT*,'-------', ME, V + 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_dhalo_tran_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_dhalo_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_dhalo_8imgs_m_b + +@test(nimgs=[std]) +subroutine test_psb_dhalo_tran_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_dhalo_tran_8imgs_m_b + +end module test_psb_dhalo + diff --git a/test/integrationTest/test_psb_dmatdist.pf b/test/integrationTest/test_psb_dmatdist.pf new file mode 100644 index 00000000..df7d1ee2 --- /dev/null +++ b/test/integrationTest/test_psb_dmatdist.pf @@ -0,0 +1,80 @@ +module test_psb_dmatdist +use pfunit_mod +use psb_base_mod +use psb_util_mod +implicit none +include 'mpif.h' +contains + +@test(nimgs=[std]) +subroutine test_psb_dmatdist1(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt + type(psb_desc_type):: desc_a + type(psb_dspmat_type) :: a, a_out + integer :: iunit=12, m_problem = 10, nv, i, nz, last, j, irow + integer, allocatable :: ipv(:), ivg(:), ia(:), ja(:) + integer, allocatable :: ia_exp(:), ja_exp(:) + real(psb_dpk_), allocatable :: val(:), val_exp(:), a_exp(:,:), a_aux(:,:) + me = this_image() + np = num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + call mm_mat_read(a,info,iunit=iunit,filename="matrix1.mtx") + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + + !Getting the expected solution + call a%csgetrow(1,10,nz,ia,ja,val,info) + allocate(ia_exp(nz),ja_exp(nz), val_exp(nz)) + last = 0 + do i=1, m_problem + if (me == ivg(i) + 1) then + irow=i + do j=1, nz + if (ia(j) == irow) then + last = last + 1 + ia_exp(last)=ia(j) + ja_exp(last)=ja(j) + val_exp(last)=val(j) + endif + enddo + endif + enddo + if (allocated(a_exp)) deallocate(a_exp) + allocate(a_exp(m_problem,m_problem)) + a_exp = 0.0d0 + do i=1,last + a_exp(ia_exp(i),ja_exp(i))=val_exp(i) + enddo + + !Test subroutine + call psb_matdist(a, a_out, icontxt, & + & desc_a,info, v=ivg) + call a_out%csgetrow(1,10,nz,ia,ja,val,info) + !Convert to global indices + call psb_loc_to_glob(ia, desc_a, info) + call psb_loc_to_glob(ja, desc_a, info) + if (allocated(a_aux)) deallocate(a_aux) + allocate(a_aux(m_problem,m_problem)) + a_aux = 0.0d0 + do i=1,last + a_aux(ia(i),ja(i))=val(i) + enddo + @assertEqual(a_aux,a_exp) + + !Free + deallocate(a_aux, a_exp, ia, ja, val) + deallocate(ipv, ivg, ia_exp, ja_exp, val_exp) + call psb_spfree(a, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_dmatdist1 + + +end module test_psb_dmatdist + diff --git a/test/integrationTest/test_psb_halo.pf b/test/integrationTest/test_psb_halo.pf index 609bbfbe..fdd36ebe 100644 --- a/test/integrationTest/test_psb_halo.pf +++ b/test/integrationTest/test_psb_halo.pf @@ -5,43 +5,45 @@ implicit none include 'mpif.h' contains -@test(nimgs=[std]) -subroutine test_psb_halotran_m_2imgs(this) - implicit none - Class(CafTestMethod), intent(inout) :: this - integer :: msg, me, i=0, np, j, info + +! 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_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt, info + integer, intent(in) :: np + integer :: me, i=0, j integer, parameter :: nrows=6 - integer :: icontxt, mid, true + integer :: mid, true integer, allocatable :: vg(:), ia(:) real(psb_dpk_), allocatable :: val(:) - real(psb_dpk_), allocatable :: v(:), y(:,:), check(:) integer(psb_ipk_) :: iictxt, icomm, flag - type(psb_desc_type):: desc_a - type(psb_d_vect_type) :: x - - np = this%getNumImages() + 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) - !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 - + !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 @@ -50,11 +52,11 @@ subroutine test_psb_halotran_m_2imgs(this) 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 @@ -68,106 +70,98 @@ subroutine test_psb_halotran_m_2imgs(this) 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) - call psb_barrier(icontxt) - v = x%get_vect() - !Let's modify x, so we need to update halo indices + sync all + !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 + x%v%v(mid +1)=x%v%v(mid+1) + 2.0d0 endif - call psb_barrier(icontxt) - - ! END OF SETUP - - v = x%get_vect() - allocate(y(size(v,1),1)) - y(:,1)=v - call psb_halo(y, desc_a, info, tran='T') - !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)) + allocate(check(mid+1), STAT=info) else - allocate(check(1)) + 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.0d0 - check(mid)=2.0d0 + check(1:mid)=1.0d0 check(mid + 1)=2.0d0 else if (me == 2) then - check(1)=6.0d0 - check(mid-1:mid)=4.0d0 + 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,v,y,check) - - call psb_gefree(x, desc_a, info) - call psb_cdfree(desc_a, info) - - call psb_exit(icontxt) -end subroutine test_psb_halotran_m_2imgs - -@test(nimgs=[std]) -subroutine test_psb_halotran_v_2imgs(this) - implicit none - Class(CafTestMethod), intent(inout) :: this - integer :: msg, me, i=0, np, j, info + 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_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt, info + integer, intent(in) :: np + integer :: me, i=0, j integer, parameter :: nrows=6 - integer :: icontxt, mid, true + integer :: mid, true integer, allocatable :: vg(:), ia(:) real(psb_dpk_), allocatable :: val(:) - real(psb_dpk_), allocatable :: v(:), check(:) integer(psb_ipk_) :: iictxt, icomm, flag - type(psb_desc_type):: desc_a - type(psb_d_vect_type) :: x - - np = this%getNumImages() + 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) - !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 - + !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 @@ -176,11 +170,11 @@ subroutine test_psb_halotran_v_2imgs(this) 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 @@ -194,629 +188,416 @@ subroutine test_psb_halotran_v_2imgs(this) 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) - call psb_barrier(icontxt) - v = x%get_vect() - !Let's modify x, so we need to update halo indices + sync all + !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 + x%v%v(mid +1)=x%v%v(mid+1) + 2.0d0 endif - call psb_barrier(icontxt) - - ! END OF SETUP - - v = x%get_vect() - call psb_halo(v, desc_a, info, tran='T') - !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)) + allocate(check(mid+1), STAT=info) else - allocate(check(1)) + 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.0d0 - check(mid)=2.0d0 - check(mid + 1)=2.0d0 + check(mid)=4.0d0 + check(mid + 1)=4.0d0 else if (me == 2) then check(1)=6.0d0 - check(mid-1:mid)=4.0d0 - check(mid + 1)=1.0d0 + check(mid-1:mid)=2.0d0 + check(mid + 1)=3.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) + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) - call psb_exit(icontxt) +end subroutine prepare_test2imgs_tran -end subroutine test_psb_halotran_v_2imgs -@test(nimgs=[std]) -subroutine test_psb_halotran_2imgs(this) +subroutine prepare_test4imgs(desc_a,x,check,np,icontxt, info) 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(:) + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), 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(:) real(psb_dpk_), allocatable :: val(:) - real(psb_dpk_), allocatable :: v(:), check(:) integer(psb_ipk_) :: iictxt, icomm, flag - type(psb_desc_type):: desc_a - type(psb_d_vect_type) :: x + class(psb_xch_idx_type), pointer :: xchg - np = this%getNumImages() - if (np < 2) then - print*,'You need at least 2 processes to run this test.' + 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) - !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 + !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 2 processes - !Assuming nrows is a multiple of 2 so mid is an integer + !Use only 4 processes + !Assuming nrows is a multiple of 4 so mid is an integer !Distribute equally to the two processes - mid=nrows/2 + + mid=nrows/4 do i=1, mid vg(i)=0 enddo - do i=mid+1, nrows + do i=mid+1, 2*mid vg(i)=1 enddo - - - do i=1,size(ia,1) - ia(i)=i + do i=2*mid + 1, 3*mid + vg(i)=2 enddo - - do i=1,mid - val(i)=1. + do i=3*mid+1, nrows + vg(i)=3 enddo - do i=mid + 1,nrows - val(i)=2. - 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 - 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) + if (me == 1) then - !Let's modify x, so we need to update halo indices + ia(1)=2 + ja(1)=1 - 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) + ia(2)=1 + ja(2)=2 - call psb_barrier(icontxt) - v = x%get_vect() - ! END OF SETUP + ia(3)=2 + ja(3)=3 - call psb_halo(x, desc_a, info, tran='T') - !GETTING BACK X - call psb_barrier(icontxt) - v = x%get_vect() - !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)=1.0d0 - check(mid)=2.0d0 - check(mid + 1)=2.0d0 - else if (me == 2) then - check(1)=6.0d0 - check(mid-1:mid)=4.0d0 - check(mid + 1)=1.0d0 - else - check(1)=0.0d0 - endif - !call psb_barrier(icontxt) + ia(4)=1 + ja(4)=4 - if ((me==1).or.(me==2)) then - true = 1 - else - true=0 + ia(5)=2 + ja(5)=5 endif - @assertEqual(real(true*check),real(true*v)) - deallocate(vg,ia,val,v,check) + if (me == 2) then - call psb_gefree(x, desc_a, info) - call psb_cdfree(desc_a, info) + ia(1)=4 + ja(1)=1 - call psb_exit(icontxt) + ia(2)=3 + ja(2)=2 -end subroutine test_psb_halotran_2imgs + ia(3)=4 + ja(3)=3 + ia(4)=3 + ja(4)=4 -@test(nimgs=[std]) -subroutine test_psb_halom_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(:,:),v(:), check(:) - integer(psb_ipk_) :: iictxt, icomm, flag - type(psb_desc_type):: desc_a - type(psb_d_vect_type) :: x + ia(5)=4 + ja(5)=5 + + ia(6)=3 + ja(6)=6 + + ia(7)=4 + ja(7)=6 - 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 + if (me == 3) then + ia(1)=5 + ja(1)=2 - !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 + ia(2)=6 + ja(2)=3 - do i=1, mid - vg(i)=0 - enddo - do i=mid+1, nrows - vg(i)=1 - enddo + ia(3)=5 + ja(3)=4 + ia(4)=6 + ja(4)=5 - do i=1,size(ia,1) - ia(i)=i - enddo + ia(5)=5 + ja(5)=6 - do i=1,mid - val(i)=1. - enddo + ia(6)=6 + ja(6)=7 - do i=mid + 1,nrows - val(i)=2. - enddo + ia(7)=5 + ja(7)=8 - 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 - v(mid +1)=v(mid+1) + 2.0d0 - endif - call psb_barrier(icontxt) - - ! END OF SETUP - allocate(y(size(v,1),1)) - y(:,1)=v - call psb_halo(y, desc_a, info) - !GETTING BACK X - call psb_barrier(icontxt) - - - !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: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,v,y,check) - - call psb_gefree(x, desc_a, info) - call psb_cdfree(desc_a, info) + if (me == 4) then + ia(1)=7 + ja(1)=4 - call psb_exit(icontxt) + ia(2)=8 + ja(2)=5 -end subroutine test_psb_halom_2imgs + ia(3)=7 + ja(3)=6 -@test(nimgs=[std]) -subroutine test_psb_halov_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(:) - integer(psb_ipk_) :: iictxt, icomm, flag - type(psb_desc_type):: desc_a - type(psb_d_vect_type) :: x + ia(4)=8 + ja(4)=7 - np = this%getNumImages() - if (np < 2) then - print*,'You need at least 2 processes to run this test.' - return + ia(5)=7 + ja(5)=8 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 + 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) - 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_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=ia, val=val,x=x, desc_a=desc_a, info=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) - call psb_barrier(icontxt) - v = x%get_vect() - !Let's modify x, so we need to update halo indices + 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 - if ((me == 1).or.(me == 2)) then - x%v%v(mid +1)=x%v%v(mid+1) + 2.0d0 endif - call psb_barrier(icontxt) + if (me == 4) then + check(1)=32 + check(2)=32 + check(3)=8 + check(4)=18 + check(5)=18 + endif ! END OF SETUP - v = x%get_vect() - call psb_halo(v, desc_a, info) - !GETTING BACK X call psb_barrier(icontxt) + !We can do something better here + x%v%v = x%v%v*2*me - !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: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) + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) -end subroutine test_psb_halov_2imgs +end subroutine prepare_test4imgs -@test(nimgs=[std]) -subroutine test_psb_halovect_2imgs(this) +subroutine prepare_test4imgs_tran(desc_a,x,check,np,icontxt, info) 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(:) + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), 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(:) real(psb_dpk_), allocatable :: val(:) - real(psb_dpk_), allocatable :: v(:), check(:) integer(psb_ipk_) :: iictxt, icomm, flag - type(psb_desc_type):: desc_a - type(psb_d_vect_type) :: x + class(psb_xch_idx_type), pointer :: xchg - np = this%getNumImages() - if (np < 2) then - print*,'You need at least 2 processes to run this test.' + 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) - !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 + !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 2 processes - !Assuming nrows is a multiple of 2 so mid is an integer + !Use only 4 processes + !Assuming nrows is a multiple of 4 so mid is an integer !Distribute equally to the two processes - mid=nrows/2 + + mid=nrows/4 do i=1, mid vg(i)=0 enddo - do i=mid+1, nrows + 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 - do i=1,size(ia,1) - ia(i)=i - enddo - do i=1,mid - val(i)=1. - enddo + if (me == 1) then - do i=mid + 1,nrows - val(i)=2. - enddo + ia(1)=2 + ja(1)=1 - 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) + ia(2)=1 + ja(2)=2 - 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) + ia(3)=2 + ja(3)=3 - call psb_barrier(icontxt) - v = x%get_vect() - !Let's modify x, so we need to update halo indices + ia(4)=1 + ja(4)=4 - if ((me == 1).or.(me == 2)) then - x%v%v(mid +1)=x%v%v(mid+1) + 2.0d0 + ia(5)=2 + ja(5)=5 endif - call psb_barrier(icontxt) - ! END OF SETUP + if (me == 2) then - - call psb_halo(x, desc_a, info) - !GETTING BACK X - call psb_barrier(icontxt) - v = x%get_vect() - - !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: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_halovect_2imgs - - - -@test(nimgs=[std]) -subroutine test_psb_d_halo(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 - 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 - - 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(1)=4 + ja(1)=1 ia(2)=3 ja(2)=2 @@ -895,99 +676,1761 @@ subroutine test_psb_d_halo(this) 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 (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 + check(1)=6 + check(2)=12 + check(3)=4 + check(4)=4 + check(5)=6 endif if (me == 2) then - check(1)=8 - check(2)=8 - check(3)=2 - check(4)=2 - check(5)=18 - check(6)=18 + 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)=18 - check(2)=18 - check(3)=1 - check(4)=8 - check(5)=8 - check(6)=32 - check(7)=32 + 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)=32 - check(2)=32 - check(3)=8 - check(4)=18 - check(5)=18 + check(1)=56 + check(2)=56 + check(3)=16 + check(4)=24 + check(5)=24 endif - 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) + ! END OF SETUP - allocate(irw(nrows)) - do i=1,nrows - irw(i)=i + 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 + +subroutine prepare_test8imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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 - 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) then + ia(1)=1 + ja(1)=6 - ! END OF SETUP + endif - !We can do something better here - x%v%v = x%v%v*2*me + if (me == 2) then - call psb_barrier(icontxt) + ia(1)=2 + ja(1)=1 + ia(2)=2 + ja(2)=7 - call psb_halo(x, desc_a, info) + endif + if (me == 3) then + ia(1)=3 + ja(1)=1 + ia(2)=3 + ja(2)=2 - call psb_barrier(icontxt) + ia(3)=3 + ja(3)=8 - v = x%get_vect() + endif + if (me == 4) then + ia(1)=4 + ja(1)=2 + ia(2)=4 + ja(2)=3 + endif - call psb_barrier(icontxt) + if (me == 5) then + ia(1)=5 + ja(1)=3 - if ((me==1).or.(me==2)) then - true = 1 - else - true=0 + ia(2)=5 + ja(2)=4 endif + if (me == 6) then + ia(1)=6 + ja(1)=4 - @assertEqual(real(true*check),real(true*v)) + ia(2)=6 + ja(2)=5 + endif - deallocate(vg,ia,val,v,check) + if (me == 7) then + ia(1)=7 + ja(1)=5 - call psb_gefree(x, desc_a, info) - call psb_cdfree(desc_a, info) + ia(2)=7 + ja(2)=6 + endif - call psb_exit(icontxt) + 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 + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + allocate(irw(nrows)) + do i=1,nrows + irw(i)=i + enddo -end subroutine test_psb_d_halo + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs + +subroutine prepare_test8imgs_tran(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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 + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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)=9 + check(2)=7 + endif + if (me == 2) then + check(1)=15 + check(2)=3 + check(3)=9 + endif + if (me == 3) then + check(1)=21 + check(2)=4 + check(3)=5 + check(4)=11 + + endif + if (me == 4) then + check(1)=27 + check(2)=6 + check(3)=7 + endif + if (me == 5) then + check(1)=33 + check(2)=8 + check(3)=9 + endif + if (me == 6) then + check(1)=46 + check(2)=10 + check(3)=13 + endif + if (me == 7) then + check(1)=38 + check(2)=12 + check(3)=13 + endif + if (me == 8) then + check(1)=27 + check(2)=14 + check(3)=15 + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs_tran + +subroutine prepare_test8imgs_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), 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)=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 + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_b + + +subroutine prepare_test8imgs_tran_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=44 + check(2)=3 + check(3)=4 + check(4)=5 + check(5)=6 + check(6)=7 + check(7)=8 + check(8)=9 + endif + if (me == 2) then + check(1)=7 + check(2)=3 + endif + if (me == 3) then + check(1)=10 + check(2)=4 + + endif + if (me == 4) then + check(1)=13 + check(2)=5 + endif + if (me == 5) then + check(1)=16 + check(2)=6 + endif + if (me == 6) then + check(1)=19 + check(2)=7 + endif + if (me == 7) then + check(1)=22 + check(2)=8 + endif + if (me == 8) then + check(1)=25 + check(2)=9 + 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 + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_tran_b + +@test(nimgs=[std]) +subroutine test_psb_halo_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_tran_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_halo_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_tran_2imgs_vect + + +@test(nimgs=[std]) +subroutine test_psb_halo_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_tran_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_halo_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_tran_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_halo_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_tran_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_halo_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_4imgs_m + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_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_halo_tran_4imgs_m + + +@test(nimgs=[std]) +subroutine test_psb_halo_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_halo_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_halo_tran_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_halo_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_halo_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_halo_tran_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_halo_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_halo_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_halo_tran_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_halo_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_halo_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_halo_tran_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_halo_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_halo_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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() + + PRINT*,'-------', ME, V + 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_halo_tran_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_halo_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_halo_8imgs_m_b + +@test(nimgs=[std]) +subroutine test_psb_halo_tran_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_halo_tran_8imgs_m_b end module test_psb_halo diff --git a/test/integrationTest/test_psb_max.pf b/test/integrationTest/test_psb_max.pf new file mode 100644 index 00000000..c6c5d09a --- /dev/null +++ b/test/integrationTest/test_psb_max.pf @@ -0,0 +1,651 @@ +module test_psb_max +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_itest_s + module procedure prepare_stest_s + module procedure prepare_dtest_s + + module procedure prepare_itest_v + module procedure prepare_stest_v + module procedure prepare_dtest_v + + module procedure prepare_itest_m + module procedure prepare_stest_m + module procedure prepare_dtest_m +end interface prepare_test + +interface prepare_test2 + module procedure prepare_itest2_s + module procedure prepare_stest2_s + module procedure prepare_dtest2_s + + module procedure prepare_itest2_v + module procedure prepare_stest2_v + module procedure prepare_dtest2_v + + module procedure prepare_itest2_m + module procedure prepare_stest2_m + module procedure prepare_dtest2_m +end interface prepare_test2 + +contains + + subroutine prepare_itest_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + check= np + endif + end subroutine prepare_itest_s + + subroutine prepare_stest_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np + 1) + check = dat + if (me == root + 1) then + check= real(np)/real(np + 1) + endif + end subroutine prepare_stest_s + + subroutine prepare_dtest_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np + 1) + check = dat + if (me == root + 1) then + check= dble(np)/dble(np + 1) + endif + end subroutine prepare_dtest_s + + + subroutine prepare_itest_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + check= np + endif + end subroutine prepare_itest_v + + subroutine prepare_stest_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np + 1) + check = dat + if (me == root + 1) then + check= real(np)/real(np + 1) + endif + end subroutine prepare_stest_v + + subroutine prepare_dtest_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np + 1) + check = dat + if (me == root + 1) then + check= dble(np)/dble(np + 1) + endif + end subroutine prepare_dtest_v + + + subroutine prepare_itest_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + check= np + endif + end subroutine prepare_itest_m + + subroutine prepare_stest_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np + 1) + check = dat + if (me == root + 1) then + check= real(np)/real(np + 1) + endif + end subroutine prepare_stest_m + + subroutine prepare_dtest_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np + 1) + check = dat + if (me == root + 1) then + check= dble(np)/dble(np + 1) + endif + end subroutine prepare_dtest_m + + subroutine prepare_itest2_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check= np + end subroutine prepare_itest2_s + + subroutine prepare_stest2_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np + 1) + check= real(np)/real(np + 1) + end subroutine prepare_stest2_s + + subroutine prepare_dtest2_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np + 1) + check= dble(np)/dble(np + 1) + end subroutine prepare_dtest2_s + + + subroutine prepare_itest2_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check= np + end subroutine prepare_itest2_v + + subroutine prepare_stest2_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np + 1) + check= real(np)/real(np + 1) + end subroutine prepare_stest2_v + + subroutine prepare_dtest2_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np + 1) + check= dble(np)/dble(np + 1) + end subroutine prepare_dtest2_v + + + subroutine prepare_itest2_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check= np + end subroutine prepare_itest2_m + + subroutine prepare_stest2_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np + 1) + check= real(np)/real(np + 1) + end subroutine prepare_stest2_m + + subroutine prepare_dtest2_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np + 1) + check= dble(np)/dble(np + 1) + end subroutine prepare_dtest2_m + +!--------- REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_imax_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + print*,'dat, check before', dat, check, this_image() + call psb_max(icontxt, dat, root) + print*,'dat after', dat, this_image() + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_imax_s + +@test(nimgs=[std]) +subroutine test_psb_smax_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_smax_s + +@test(nimgs=[std]) +subroutine test_psb_dmax_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + print*,'dat, check before', dat, check, this_image() + call psb_max(icontxt, dat, root) + print*,'dat after', dat, this_image() + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_dmax_s + + +@test(nimgs=[std]) +subroutine test_psb_imax_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_imax_v + +@test(nimgs=[std]) +subroutine test_psb_smax_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_smax_v + +@test(nimgs=[std]) +subroutine test_psb_dmax_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_dmax_v + + +@test(nimgs=[std]) +subroutine test_psb_imax_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_imax_m + +@test(nimgs=[std]) +subroutine test_psb_smax_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_smax_m + +@test(nimgs=[std]) +subroutine test_psb_dmax_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_dmax_m + +@test(nimgs=[std]) +subroutine test2_psb_imax_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + print*,'dat, check before', dat, check, this_image() + call psb_max(icontxt, dat, root) + print*,'dat after', dat, this_image() + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_imax_s + +@test(nimgs=[std]) +subroutine test2_psb_smax_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_smax_s + +@test(nimgs=[std]) +subroutine test2_psb_dmax_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + print*,'dat, check before', dat, check, this_image() + call psb_max(icontxt, dat, root) + print*,'dat after', dat, this_image() + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_dmax_s + + +@test(nimgs=[std]) +subroutine test2_psb_imax_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_imax_v + +@test(nimgs=[std]) +subroutine test2_psb_smax_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_smax_v + +@test(nimgs=[std]) +subroutine test2_psb_dmax_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_dmax_v + + +@test(nimgs=[std]) +subroutine test2_psb_imax_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_imax_m + +@test(nimgs=[std]) +subroutine test2_psb_smax_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_smax_m + +@test(nimgs=[std]) +subroutine test2_psb_dmax_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_max(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_dmax_m + +end module test_psb_max diff --git a/test/integrationTest/test_psb_min.pf b/test/integrationTest/test_psb_min.pf new file mode 100644 index 00000000..fe66d64e --- /dev/null +++ b/test/integrationTest/test_psb_min.pf @@ -0,0 +1,645 @@ +module test_psb_min +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_itest_s + module procedure prepare_stest_s + module procedure prepare_dtest_s + + module procedure prepare_itest_v + module procedure prepare_stest_v + module procedure prepare_dtest_v + + module procedure prepare_itest_m + module procedure prepare_stest_m + module procedure prepare_dtest_m +end interface prepare_test + +interface prepare_test2 + module procedure prepare_itest2_s + module procedure prepare_stest2_s + module procedure prepare_dtest2_s + + module procedure prepare_itest2_v + module procedure prepare_stest2_v + module procedure prepare_dtest2_v + + module procedure prepare_itest2_m + module procedure prepare_stest2_m + module procedure prepare_dtest2_m +end interface prepare_test2 + +contains + + subroutine prepare_itest_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + check= 1 + endif + end subroutine prepare_itest_s + + subroutine prepare_stest_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np) + check = dat + if (me == root + 1) then + check= real(1)/real(np) + endif + end subroutine prepare_stest_s + + subroutine prepare_dtest_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np) + check = dat + if (me == root + 1) then + check= dble(1)/dble(np) + endif + end subroutine prepare_dtest_s + + + subroutine prepare_itest_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + check= 1 + endif + end subroutine prepare_itest_v + + subroutine prepare_stest_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np) + check = dat + if (me == root + 1) then + check= real(1)/real(np) + endif + end subroutine prepare_stest_v + + subroutine prepare_dtest_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np) + check = dat + if (me == root + 1) then + check= dble(1)/dble(np) + endif + end subroutine prepare_dtest_v + + + subroutine prepare_itest_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + check= 1 + endif + end subroutine prepare_itest_m + + subroutine prepare_stest_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np) + check = dat + if (me == root + 1) then + check= real(1)/real(np) + endif + end subroutine prepare_stest_m + + subroutine prepare_dtest_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np) + check = dat + if (me == root + 1) then + check= dble(1)/dble(np) + endif + end subroutine prepare_dtest_m + + subroutine prepare_itest2_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check= 1 + end subroutine prepare_itest2_s + + subroutine prepare_stest2_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np) + check= real(1)/real(np) + end subroutine prepare_stest2_s + + subroutine prepare_dtest2_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np) + check= dble(1)/dble(np) + end subroutine prepare_dtest2_s + + + subroutine prepare_itest2_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check= 1 + end subroutine prepare_itest2_v + + subroutine prepare_stest2_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np) + check= real(1)/real(np) + end subroutine prepare_stest2_v + + subroutine prepare_dtest2_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np) + check= dble(1)/dble(np) + end subroutine prepare_dtest2_v + + + subroutine prepare_itest2_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check= 1 + end subroutine prepare_itest2_m + + subroutine prepare_stest2_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image())/real(np) + check= real(1)/real(np) + end subroutine prepare_stest2_m + + subroutine prepare_dtest2_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image())/dble(np) + check= dble(1)/dble(np) + end subroutine prepare_dtest2_m + + +!--------- REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_imin_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_imin_s + +@test(nimgs=[std]) +subroutine test_psb_smin_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_smin_s + +@test(nimgs=[std]) +subroutine test_psb_dmin_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test_psb_dmin_s + + +@test(nimgs=[std]) +subroutine test_psb_imin_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_imin_v + +@test(nimgs=[std]) +subroutine test_psb_smin_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_smin_v + +@test(nimgs=[std]) +subroutine test_psb_dmin_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_dmin_v + + +@test(nimgs=[std]) +subroutine test_psb_imin_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_imin_m + +@test(nimgs=[std]) +subroutine test_psb_smin_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_smin_m + +@test(nimgs=[std]) +subroutine test_psb_dmin_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test_psb_dmin_m + +@test(nimgs=[std]) +subroutine test2_psb_imin_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_imin_s + +@test(nimgs=[std]) +subroutine test2_psb_smin_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_smin_s + +@test(nimgs=[std]) +subroutine test2_psb_dmin_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + call psb_exit(icontxt) +end subroutine test2_psb_dmin_s + + +@test(nimgs=[std]) +subroutine test2_psb_imin_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_imin_v + +@test(nimgs=[std]) +subroutine test2_psb_smin_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_smin_v + +@test(nimgs=[std]) +subroutine test2_psb_dmin_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_dmin_v + + +@test(nimgs=[std]) +subroutine test2_psb_imin_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_imin_m + +@test(nimgs=[std]) +subroutine test2_psb_smin_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_smin_m + +@test(nimgs=[std]) +subroutine test2_psb_dmin_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_min(icontxt, dat, root) + @assertEqual(dat,check) + deallocate(dat, check) + call psb_exit(icontxt) +end subroutine test2_psb_dmin_m + + +end module test_psb_min diff --git a/test/integrationTest/test_psb_reduce_nrm2.pf b/test/integrationTest/test_psb_reduce_nrm2.pf new file mode 100644 index 00000000..941c18b6 --- /dev/null +++ b/test/integrationTest/test_psb_reduce_nrm2.pf @@ -0,0 +1,369 @@ +module test_psb_reduce_nrm2 +use pfunit_mod +use psb_base_mod +use psi_reduce_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_ctest2imgs + module procedure prepare_stest2imgs + module procedure prepare_dtest2imgs +end interface prepare_test + +contains +subroutine prepare_ctest2imgs(desc_a,x,result, np, icontxt, info) + use psb_base_mod + IMPLICIT NONE + type(psb_desc_type), intent(out):: desc_a + type(psb_c_vect_type), intent(out) :: x + real(psb_spk_), intent(out) :: result + 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(:) + complex(psb_spk_), 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.,1.) + enddo + + do i=mid + 1,nrows + val(i)=(2.,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.0,2.0) + endif + + !Let's build the expected solution + result = 5.47722578E0 + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_ctest2imgs + +subroutine prepare_stest2imgs(desc_a,x,result, np, icontxt, info) + use psb_base_mod + IMPLICIT NONE + type(psb_desc_type), intent(out):: desc_a + type(psb_s_vect_type), intent(out) :: x + real(psb_spk_), intent(out) :: result + 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(:) + real(psb_spk_), 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 + result = 3.87298322E0 + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_stest2imgs +subroutine prepare_dtest2imgs(desc_a,x,result, np, icontxt, info) + use psb_base_mod + IMPLICIT NONE + type(psb_desc_type), intent(out):: desc_a + type(psb_d_vect_type), intent(out) :: x + real(psb_dpk_), intent(out) :: result + 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(:) + real(psb_dpk_), 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 + result = 3.8729833462074170d0 + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_dtest2imgs + +!--------- REAL TESTS +@test(nimgs=[std]) +subroutine test_psb_cnrm2_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + type(psb_desc_type):: desc_a + type(psb_c_vect_type) :: x + complex(psb_spk_), allocatable :: v(:) + integer :: info, np, icontxt + real(psb_spk_) :: expected, result + np = num_images() + call prepare_test(desc_a,x,expected, np, icontxt, info) + v=x%get_vect() + call psb_genrm2s(result, v, desc_a,info) + @assertEqual(result,expected) + if (allocated(v)) deallocate(v) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_cnrm2_s + +@test(nimgs=[std]) +subroutine test_psb_snrm2_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + real(psb_spk_), allocatable :: v(:) + integer :: info, np, icontxt + real(psb_spk_) :: expected, result + np = num_images() + call prepare_test(desc_a,x,expected, np, icontxt, info) + v=x%get_vect() + call psb_genrm2s(result, v, desc_a,info) + @assertEqual(result,expected) + if (allocated(v)) deallocate(v) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_snrm2_s + +@test(nimgs=[std]) +subroutine test_psb_dnrm2_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + type(psb_desc_type):: desc_a + type(psb_d_vect_type) :: x + real(psb_dpk_), allocatable :: v(:) + integer :: info, np, icontxt + real(psb_dpk_) :: expected, result + np = num_images() + call prepare_test(desc_a,x,expected, np, icontxt, info) + v=x%get_vect() + call psb_genrm2s(result, v, desc_a,info) + @assertEqual(result,expected) + call psb_gefree(x, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(icontxt) +end subroutine test_psb_dnrm2_s + +end module test_psb_reduce_nrm2 + diff --git a/test/integrationTest/test_psb_shalo.pf b/test/integrationTest/test_psb_shalo.pf new file mode 100644 index 00000000..55d49673 --- /dev/null +++ b/test/integrationTest/test_psb_shalo.pf @@ -0,0 +1,2436 @@ +module test_psb_shalo +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_s_vect_type), intent(out) :: x + real(psb_spk_), 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(:) + real(psb_spk_), 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.0E0 + check(mid + 1)=2.0E0 + else if (me == 2) then + check(1:mid)=2.0E0 + check(mid + 1)=1.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 + +! 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_s_vect_type), intent(out) :: x + real(psb_spk_), 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(:) + real(psb_spk_), 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_s_vect_type), intent(out) :: x + real(psb_spk_), 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(:) + real(psb_spk_), 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_s_vect_type), intent(out) :: x + real(psb_spk_), 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(:) + real(psb_spk_), 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 + +subroutine prepare_test8imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_s_vect_type), intent(out) :: x + real(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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 + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs + +subroutine prepare_test8imgs_tran(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_s_vect_type), intent(out) :: x + real(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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 + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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)=9 + check(2)=7 + endif + if (me == 2) then + check(1)=15 + check(2)=3 + check(3)=9 + endif + if (me == 3) then + check(1)=21 + check(2)=4 + check(3)=5 + check(4)=11 + + endif + if (me == 4) then + check(1)=27 + check(2)=6 + check(3)=7 + endif + if (me == 5) then + check(1)=33 + check(2)=8 + check(3)=9 + endif + if (me == 6) then + check(1)=46 + check(2)=10 + check(3)=13 + endif + if (me == 7) then + check(1)=38 + check(2)=12 + check(3)=13 + endif + if (me == 8) then + check(1)=27 + check(2)=14 + check(3)=15 + 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 + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs_tran + +subroutine prepare_test8imgs_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_s_vect_type), intent(out) :: x + real(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), 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)=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 + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_b + + +subroutine prepare_test8imgs_tran_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_s_vect_type), intent(out) :: x + real(psb_spk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + real(psb_spk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=44 + check(2)=3 + check(3)=4 + check(4)=5 + check(5)=6 + check(6)=7 + check(7)=8 + check(8)=9 + endif + if (me == 2) then + check(1)=7 + check(2)=3 + endif + if (me == 3) then + check(1)=10 + check(2)=4 + + endif + if (me == 4) then + check(1)=13 + check(2)=5 + endif + if (me == 5) then + check(1)=16 + check(2)=6 + endif + if (me == 6) then + check(1)=19 + check(2)=7 + endif + if (me == 7) then + check(1)=22 + check(2)=8 + endif + if (me == 8) then + check(1)=25 + check(2)=9 + 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 + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_tran_b + +@test(nimgs=[std]) +subroutine test_psb_shalo_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_tran_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_shalo_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_tran_2imgs_vect + + +@test(nimgs=[std]) +subroutine test_psb_shalo_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_tran_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_shalo_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_tran_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_shalo_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_tran_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_shalo_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_4imgs_m + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_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_shalo_tran_4imgs_m + + +@test(nimgs=[std]) +subroutine test_psb_shalo_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_shalo_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_shalo_tran_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_shalo_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_shalo_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_shalo_tran_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_shalo_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_shalo_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_shalo_tran_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_shalo_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_shalo_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_shalo_tran_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_shalo_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_shalo_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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() + + PRINT*,'-------', ME, V + 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_shalo_tran_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_shalo_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_shalo_8imgs_m_b + +@test(nimgs=[std]) +subroutine test_psb_shalo_tran_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + real(psb_spk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_s_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_shalo_tran_8imgs_m_b + +end module test_psb_shalo + diff --git a/test/integrationTest/test_psb_sum.pf b/test/integrationTest/test_psb_sum.pf new file mode 100644 index 00000000..7f34f59d --- /dev/null +++ b/test/integrationTest/test_psb_sum.pf @@ -0,0 +1,1139 @@ +module test_psb_sum +use pfunit_mod +use psb_base_mod +implicit none +include 'mpif.h' + +interface prepare_test + module procedure prepare_itest_s + module procedure prepare_stest_s + module procedure prepare_dtest_s + module procedure prepare_ctest_s + module procedure prepare_ztest_s + + module procedure prepare_itest_v + module procedure prepare_stest_v + module procedure prepare_dtest_v + module procedure prepare_ctest_v + module procedure prepare_ztest_v + + module procedure prepare_itest_m + module procedure prepare_stest_m + module procedure prepare_dtest_m + module procedure prepare_ctest_m + module procedure prepare_ztest_m +end interface prepare_test + +interface prepare_test2 + module procedure prepare_itest2_s + module procedure prepare_stest2_s + module procedure prepare_dtest2_s + module procedure prepare_ctest2_s + module procedure prepare_ztest2_s + + module procedure prepare_itest2_v + module procedure prepare_stest2_v + module procedure prepare_dtest2_v + module procedure prepare_ctest2_v + module procedure prepare_ztest2_v + + module procedure prepare_itest2_m + module procedure prepare_stest2_m + module procedure prepare_dtest2_m + module procedure prepare_ctest2_m + module procedure prepare_ztest2_m +end interface prepare_test2 + +contains + + subroutine prepare_itest_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=(np +1)*(np/2) + else + check=(np +1)*(np/2) + (np + 1)/2 + endif + endif + end subroutine prepare_itest_s + + subroutine prepare_stest_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=real((np +1)*(np/2)) + else + check=real((np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_stest_s + + subroutine prepare_dtest_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=dble((np +1)*(np/2)) + else + check=dble((np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_dtest_s + + subroutine prepare_ctest_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_ctest_s + + subroutine prepare_ztest_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=0 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_ztest_s + + + subroutine prepare_itest_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=(np +1)*(np/2) + else + check=(np +1)*(np/2) + (np + 1)/2 + endif + endif + end subroutine prepare_itest_v + + subroutine prepare_stest_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=real((np +1)*(np/2)) + else + check=real((np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_stest_v + + subroutine prepare_dtest_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=dble((np +1)*(np/2)) + else + check=dble((np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_dtest_v + + subroutine prepare_ctest_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_ctest_v + + subroutine prepare_ztest_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(), this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_ztest_v + + + subroutine prepare_itest_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=(np +1)*(np/2) + else + check=(np +1)*(np/2) + (np + 1)/2 + endif + endif + end subroutine prepare_itest_m + + subroutine prepare_stest_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=real((np +1)*(np/2)) + else + check=real((np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_stest_m + + subroutine prepare_dtest_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=dble((np +1)*(np/2)) + else + check=dble((np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_dtest_m + + subroutine prepare_ctest_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_ctest_m + + subroutine prepare_ztest_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=0 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(), this_image()) + check = dat + if (me == root + 1) then + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + endif + end subroutine prepare_ztest_m + + subroutine prepare_itest2_s(dat,check,root,info, np, icontxt) + integer, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (mod(np,2)==0) then + check=(np +1)*(np/2) + else + check=(np +1)*(np/2) + (np + 1)/2 + endif + end subroutine prepare_itest2_s + + subroutine prepare_stest2_s(dat,check,root,info, np, icontxt) + real, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (mod(np,2)==0) then + check=real((np +1)*(np/2)) + else + check=real((np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_stest2_s + + subroutine prepare_dtest2_s(dat,check,root,info, np, icontxt) + double precision, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (mod(np,2)==0) then + check=dble((np +1)*(np/2)) + else + check=dble((np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_dtest2_s + + subroutine prepare_ctest2_s(dat,check,root,info, np, icontxt) + complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_ctest2_s + + subroutine prepare_ztest2_s(dat,check,root,info, np, icontxt) + double complex, intent(out) :: dat, check + integer, intent(out) :: root, info, np, icontxt + integer :: me + info = 0 + root=-1 + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_ztest2_s + + + subroutine prepare_itest2_v(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (mod(np,2)==0) then + check=(np +1)*(np/2) + else + check=(np +1)*(np/2) + (np + 1)/2 + endif + end subroutine prepare_itest2_v + + subroutine prepare_stest2_v(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (mod(np,2)==0) then + check=real((np +1)*(np/2)) + else + check=real((np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_stest2_v + + subroutine prepare_dtest2_v(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check = dat + if (mod(np,2)==0) then + check=dble((np +1)*(np/2)) + else + check=dble((np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_dtest2_v + + subroutine prepare_ctest2_v(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_ctest2_v + + subroutine prepare_ztest2_v(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:), check(:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_),check(size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(), this_image()) + check = dat + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_ztest2_v + + + subroutine prepare_itest2_m(dat,check,root,info, np, icontxt) + integer, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = this_image() + check = dat + if (mod(np,2)==0) then + check=(np +1)*(np/2) + else + check=(np +1)*(np/2) + (np + 1)/2 + endif + end subroutine prepare_itest2_m + + subroutine prepare_stest2_m(dat,check,root,info, np, icontxt) + real, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = real(this_image()) + check = dat + if (mod(np,2)==0) then + check=real((np +1)*(np/2)) + else + check=real((np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_stest2_m + + subroutine prepare_dtest2_m(dat,check,root,info, np, icontxt) + double precision, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = dble(this_image()) + check = dat + if (mod(np,2)==0) then + check=dble((np +1)*(np/2)) + else + check=dble((np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_dtest2_m + + subroutine prepare_ctest2_m(dat,check,root,info, np, icontxt) + complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(),this_image()) + check = dat + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_ctest2_m + + subroutine prepare_ztest2_m(dat,check,root,info, np, icontxt) + double complex, allocatable, intent(out) :: dat(:,:), check(:,:) + integer, intent(out) :: root, info, np, icontxt + integer :: me + integer, parameter :: size_=23 + info = 0 + root=-1 + if (allocated(dat)) deallocate(dat) + if (allocated(dat)) deallocate(check) + allocate(dat(size_,size_),check(size_,size_), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + me=this_image() + np= num_images() + call psb_init(icontxt,np,MPI_COMM_WORLD) + dat = complex(this_image(), this_image()) + check = dat + if (mod(np,2)==0) then + check=complex((np +1)*(np/2),(np +1)*(np/2)) + else + check=complex((np +1)*(np/2) + (np + 1)/2,(np +1)*(np/2) + (np + 1)/2) + endif + end subroutine prepare_ztest2_m + +!--------- REAL TESTS + + +@test(nimgs=[std]) +subroutine test_psb_isum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_isum_s + + +@test(nimgs=[std]) +subroutine test_psb_ssum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_ssum_s + +@test(nimgs=[std]) +subroutine test_psb_dsum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_dsum_s + +@test(nimgs=[std]) +subroutine test_psb_csum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_csum_s + +@test(nimgs=[std]) +subroutine test_psb_zsum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_zsum_s + + +@test(nimgs=[std]) +subroutine test_psb_isum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_isum_v + +@test(nimgs=[std]) +subroutine test_psb_ssum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_ssum_v + +@test(nimgs=[std]) +subroutine test_psb_dsum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_dsum_v + +@test(nimgs=[std]) +subroutine test_psb_csum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_csum_v + +@test(nimgs=[std]) +subroutine test_psb_zsum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_zsum_v + + +@test(nimgs=[std]) +subroutine test_psb_isum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_isum_m + +@test(nimgs=[std]) +subroutine test_psb_ssum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_ssum_m + +@test(nimgs=[std]) +subroutine test_psb_dsum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_dsum_m + +@test(nimgs=[std]) +subroutine test_psb_csum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_csum_m + +@test(nimgs=[std]) +subroutine test_psb_zsum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test_psb_zsum_m + +@test(nimgs=[std]) +subroutine test2_psb_isum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: dat, check, root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_isum_s +@test(nimgs=[std]) +subroutine test2_psb_ssum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_ssum_s + +@test(nimgs=[std]) +subroutine test2_psb_dsum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_dsum_s + +@test(nimgs=[std]) +subroutine test2_psb_csum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_csum_s + +@test(nimgs=[std]) +subroutine test2_psb_zsum_s(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex :: dat, check + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_zsum_s + + +@test(nimgs=[std]) +subroutine test2_psb_isum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_isum_v + +@test(nimgs=[std]) +subroutine test2_psb_ssum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_ssum_v + +@test(nimgs=[std]) +subroutine test2_psb_dsum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_dsum_v + +@test(nimgs=[std]) +subroutine test2_psb_csum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_csum_v + +@test(nimgs=[std]) +subroutine test2_psb_zsum_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:), check(:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_zsum_v + + +@test(nimgs=[std]) +subroutine test2_psb_isum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_isum_m + +@test(nimgs=[std]) +subroutine test2_psb_ssum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + real, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_ssum_m + +@test(nimgs=[std]) +subroutine test2_psb_dsum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double precision, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_dsum_m + +@test(nimgs=[std]) +subroutine test2_psb_csum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_csum_m + +@test(nimgs=[std]) +subroutine test2_psb_zsum_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + double complex, allocatable :: dat(:,:), check(:,:) + integer :: root, info, np, icontxt + call prepare_test2(dat,check,root,info, np, icontxt) + call psb_sum(icontxt, dat, root) + @assertEqual(dat,check) +end subroutine test2_psb_zsum_m + + +end module test_psb_sum diff --git a/test/integrationTest/test_psb_zhalo.pf b/test/integrationTest/test_psb_zhalo.pf new file mode 100644 index 00000000..18f5e8cc --- /dev/null +++ b/test/integrationTest/test_psb_zhalo.pf @@ -0,0 +1,2440 @@ +module test_psb_zhalo +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_z_vect_type), intent(out) :: x + complex(psb_dpk_), 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(:) + complex(psb_dpk_), 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.0d0,1.0d0) + enddo + + do i=mid + 1,nrows + val(i)=(2.0d0,2.0d0) + 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,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,1.0d0) + check(mid + 1)=(2.0d0,2.0d0) + else if (me == 2) then + check(1:mid)=(2.0d0,2.0d0) + check(mid + 1)=(1.0d0,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_z_vect_type), intent(out) :: x + complex(psb_dpk_), 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(:) + complex(psb_dpk_), 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.0d0,1.0d0) + enddo + + do i=mid + 1,nrows + val(i)=(2.0d0,2.0d0) + 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,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)=(1.0d0,1.0d0) + check(mid)=(4.0d0,4.0d0) + check(mid + 1)=(4.0d0,4.0d0) + else if (me == 2) then + check(1)=(6.0d0,6.0d0) + check(mid-1:mid)=(2.0d0,2.0d0) + check(mid + 1)=(3.0d0,3.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_tran + + +subroutine prepare_test4imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_z_vect_type), intent(out) :: x + complex(psb_dpk_), 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(:) + complex(psb_dpk_), 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.0d0,1.0d0) + enddo + do i= mid + 1, 2*mid + val(i)=(2.0d0,2.0d0) + enddo + do i=2*mid + 1, 3*mid + val(i)=(3.0d0,3.0d0) + enddo + do i=3*mid + 1, nrows + val(i)=(4.0d0,4.0d0) + 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.0d0,2.0d0) + check(2)=(2.0d0,2.0d0) + check(3)=(8.0d0,8.0d0) + check(4)=(8.0d0,8.0d0) + check(5)=(18.0d0,18.0d0) + endif + if (me == 2) then + check(1)=(8.0d0,8.0d0) + check(2)=(8.0d0,8.0d0) + check(3)=(2.0d0,2.0d0) + check(4)=(2.0d0,2.0d0) + check(5)=(18.0d0,18.0d0) + check(6)=(18.0d0,18.0d0) + endif + if (me == 3) then + check(1)=(18.0d0,18.0d0) + check(2)=(18.0d0,18.0d0) + check(3)=(1.0d0,1.0d0) + check(4)=(8.0d0,8.0d0) + check(5)=(8.0d0,8.0d0) + check(6)=(32.0d0,32.0d0) + check(7)=(32.0d0,32.0d0) + + endif + if (me == 4) then + check(1)=(32.0d0,32.0d0) + check(2)=(32.0d0,32.0d0) + check(3)=(8.0d0,8.0d0) + check(4)=(18.0d0,18.0d0) + check(5)=(18.0d0,18.0d0) + 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_z_vect_type), intent(out) :: x + complex(psb_dpk_), 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(:) + complex(psb_dpk_), 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.0d0,1.0d0) + enddo + do i= mid + 1, 2*mid + val(i)=(2.0d0,2.0d0) + enddo + do i=2*mid + 1, 3*mid + val(i)=(3.0d0,3.0d0) + enddo + do i=3*mid + 1, nrows + val(i)=(4.0d0,4.0d0) + 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.0d0,6.0d0) + check(2)=(12.0d0,12.0d0) + check(3)=(4.0d0,4.0d0) + check(4)=(4.0d0,4.0d0) + check(5)=(6.0d0,6.0d0) + endif + if (me == 2) then + check(1)=(24.0d0,24.0d0) + check(2)=(40.0d0,40.0d0) + check(3)=(4.0d0,4.0d0) + check(4)=(4.0d0,4.0d0) + check(5)=(12.0d0,12.0d0) + check(6)=(12.0d0,12.0d0) + endif + if (me == 3) then + check(1)=(6.0d0,6.0d0) + check(2)=(54.0d0,54.0d0) + check(3)=(6.0d0,6.0d0) + check(4)=(12.0d0,12.0d0) + check(5)=(12.0d0,12.0d0) + check(6)=(24.0d0,24.0d0) + check(7)=(24.0d0,24.0d0) + + endif + if (me == 4) then + check(1)=(56.0d0,65.0d0) + check(2)=(56.0d0,65.0d0) + check(3)=(16.0d0,16.0d0) + check(4)=(24.0d0,24.0d0) + check(5)=(24.0d0,24.0d0) + 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 + +subroutine prepare_test8imgs(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_z_vect_type), intent(out) :: x + complex(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,me) + enddo + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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.0d0,2.0d0) + check(2)=(12.0d0,12.0d0) + endif + if (me == 2) then + check(1)=(4.0d0,4.0d0) + check(2)=(2.0d0,2.0d0) + check(3)=(14.0d0,14.0d0) + endif + if (me == 3) then + check(1)=(6.0d0,6.0d0) + check(2)=(2.0d0,2.0d0) + check(3)=(4.0d0,4.0d0) + check(4)=(16.0d0,16.0d0) + + endif + if (me == 4) then + check(1)=(8.0d0,8.0d0) + check(2)=(4.0d0,4.0d0) + check(3)=(6.0d0,6.0d0) + endif + if (me == 5) then + check(1)=(10.0d0,10.0d0) + + check(2)=(6.0d0,6.0d0) + check(3)=(8.0d0,8.0d0) + endif + if (me == 6) then + check(1)=(12.0d0,12.0d0) + check(2)=(8.0d0,8.0d0) + check(3)=(10.0d0,10.0d0) + endif + if (me == 7) then + check(1)=(14.0d0,14.0d0) + + check(2)=(10.0d0,10.0d0) + check(3)=(12.0d0,12.0d0) + endif + if (me == 8) then + check(1)=(16.0d0,16.0d0) + check(2)=(12.0d0,12.0d0) + check(3)=(14.0d0,14.0d0) + endif + if (me > 8) then + check(1)=(0.0d0,0.0d0) + endif + ! END OF SETUP + + + + call psb_barrier(icontxt) + !We can do something better here + x%v%v = x%v%v + cmplx(me,me) + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs + +subroutine prepare_test8imgs_tran(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_z_vect_type), intent(out) :: x + complex(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer :: info + integer :: me, i=0, j,nz + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,me) + enddo + + sync all + call psb_cdall(icontxt,desc_a,info, vg=vg) + if (info /=0) then + print*,'an error in desc allocation', me, info + stop + endif + + call psb_cdins(nz=nz,ia=ia,ja=ja, desc_a=desc_a, info=info) + if (info /=0) then + print*,'an error in psb_cdins', me, info + stop + endif + + call psb_cdasb(desc_a, info) + if (info /=0) then + print*,'an error in psb_cdasb', me, info + stop + endif + + + 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)=(9.0d0,9.0d0) + check(2)=(7.0d0,7.0d0) + endif + if (me == 2) then + check(1)=(15.0d0,15.0d0) + check(2)=(3.0d0,3.0d0) + check(3)=(9.0d0,9.0d0) + endif + if (me == 3) then + check(1)=(21.0d0,21.0d0) + check(2)=(4.0d0,4.0d0) + check(3)=(5.0d0,5.0d0) + check(4)=(11.0d0,11.0d0) + + endif + if (me == 4) then + check(1)=(27.0d0,27.0d0) + check(2)=(6.0d0,6.0d0) + check(3)=(7.0d0,7.0d0) + endif + if (me == 5) then + check(1)=(33.0d0,33.0d0) + check(2)=(8.0d0,8.0d0) + check(3)=(9.0d0,9.0d0) + endif + if (me == 6) then + check(1)=(46.0d0,46.0d0) + check(2)=(10.0d0,10.0d0) + check(3)=(13.0d0,13.0d0) + endif + if (me == 7) then + check(1)=(38.0d0,38.0d0) + check(2)=(12.0d0,12.0d0) + check(3)=(13.0d0,13.0d0) + endif + if (me == 8) then + check(1)=(27.0d0,27.0d0) + check(2)=(14.0d0,14.0d0) + check(3)=(15.0d0,15.0d0) + 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 + cmplx(me,me) + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + +end subroutine prepare_test8imgs_tran + +subroutine prepare_test8imgs_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_z_vect_type), intent(out) :: x + complex(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=(2.0d0,2.0d0) + check(2)=(4.0d0,4.0d0) + check(3)=(6.0d0,6.0d0) + check(4)=(8.0d0,8.0d0) + check(5)=(10.0d0,10.0d0) + check(6)=(12.0d0,12.0d0) + check(7)=(14.0d0,14.0d0) + check(8)=(16.0d0,16.0d0) + endif + if (me == 2) then + check(1)=(4.0d0,4.0d0) + check(2)=(2.0d0,2.0d0) + endif + if (me == 3) then + check(1)=(6.0d0,6.0d0) + check(2)=(2.0d0,2.0d0) + + endif + if (me == 4) then + check(1)=(8.0d0,8.0d0) + check(2)=(2.0d0,2.0d0) + endif + if (me == 5) then + check(1)=(10.0d0,10.0d0) + + check(2)=(2.0d0,2.0d0) + endif + if (me == 6) then + check(1)=(12.0d0,12.0d0) + check(2)=(2.0d0,2.0d0) + endif + if (me == 7) then + check(1)=(14.0d0,14.0d0) + + check(2)=(2.0d0,2.0d0) + endif + if (me == 8) then + check(1)=(16.0d0,16.0d0) + check(2)=(2.0d0,2.0d0) + 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 + cmplx(me,me) + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_b + + +subroutine prepare_test8imgs_tran_b(desc_a,x,check,np,icontxt, info) + implicit none + type(psb_desc_type), intent(out):: desc_a + type(psb_z_vect_type), intent(out) :: x + complex(psb_dpk_), allocatable, intent(out) :: check(:) + integer, intent(out) :: icontxt + integer, intent(in) :: np + integer, optional :: info + integer :: me, i=0, j,nz, info_ + integer, parameter :: nrows = 8 + integer :: mid, true + integer, allocatable :: vg(:), ia(:), ja(:), irw(:) + complex(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_) :: iictxt, icomm, flag + class(psb_xch_idx_type), pointer :: xchg + + 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 + 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 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 + 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)=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)=cmplx(me,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) + + if (allocated(irw)) deallocate(irw) + allocate(irw(nrows), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + + 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), STAT=info) + if (info /=0) then + print*,'ERROR while allocating some vectors' + info = -1 + stop + endif + if (me == 1) then + check(1)=(44.0d0,44.0d0) + check(2)=(3.0d0,3.0d0) + check(3)=(4.0d0,4.0d0) + check(4)=(5.0d0,5.0d0) + check(5)=(6.0d0,6.0d0) + check(6)=(7.0d0,7.0d0) + check(7)=(8.0d0,8.0d0) + check(8)=(9.0d0,9.0d0) + endif + if (me == 2) then + check(1)=(7.0d0,7.0d0) + check(2)=(3.0d0,3.0d0) + endif + if (me == 3) then + check(1)=(10.0d0,10.0d0) + check(2)=(4.0d0,4.0d0) + + endif + if (me == 4) then + check(1)=(13.0d0,13.0d0) + check(2)=(5.0d0,5.0d0) + endif + if (me == 5) then + check(1)=(16.0d0,16.0d0) + check(2)=(6.0d0,6.0d0) + endif + if (me == 6) then + check(1)=(19.0d0,19.0d0) + check(2)=(7.0d0,7.0d0) + endif + if (me == 7) then + check(1)=(22.0d0,22.0d0) + check(2)=(8.0d0,8.0d0) + endif + if (me == 8) then + check(1)=(25.0d0,25.0d0) + check(2)=(9.0d0,9.0d0) + 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 + cmplx(me,me) + + + if (allocated(vg)) deallocate(vg) + if (allocated(ia)) deallocate(ia) + if (allocated(val)) deallocate(val) + if (allocated(irw)) deallocate(irw) +end subroutine prepare_test8imgs_tran_b + +@test(nimgs=[std]) +subroutine test_psb_zhalo_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_2imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_tran_2imgs_v + +@test(nimgs=[std]) +subroutine test_psb_zhalo_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_2imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_2imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_tran_2imgs_vect + + +@test(nimgs=[std]) +subroutine test_psb_zhalo_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_2imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_tran_2imgs_m + +@test(nimgs=[std]) +subroutine test_psb_zhalo_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_4imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_tran_4imgs_v + +@test(nimgs=[std]) +subroutine test_psb_zhalo_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_4imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_tran_4imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_zhalo_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_4imgs_m + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_4imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_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_zhalo_tran_4imgs_m + + +@test(nimgs=[std]) +subroutine test_psb_zhalo_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_zhalo_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_8imgs_v(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_zhalo_tran_8imgs_v + +@test(nimgs=[std]) +subroutine test_psb_zhalo_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_zhalo_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_8imgs_vect(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_zhalo_tran_8imgs_vect + +@test(nimgs=[std]) +subroutine test_psb_zhalo_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs(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_zhalo_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_8imgs_m(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_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_zhalo_tran_8imgs_m + +@test(nimgs=[std]) +subroutine test_psb_zhalo_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_zhalo_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_8imgs_v_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_zhalo_tran_8imgs_v_b + +@test(nimgs=[std]) +subroutine test_psb_zhalo_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_zhalo_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_8imgs_vect_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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() + + PRINT*,'-------', ME, V + 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_zhalo_tran_8imgs_vect_b + +@test(nimgs=[std]) +subroutine test_psb_zhalo_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_b(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_zhalo_8imgs_m_b + +@test(nimgs=[std]) +subroutine test_psb_zhalo_tran_8imgs_m_b(this) + implicit none + Class(CafTestMethod), intent(inout) :: this + integer :: me, np, info + integer :: icontxt, true + complex(psb_dpk_), allocatable :: v(:), m(:,:), check(:) + type(psb_desc_type):: desc_a + type(psb_z_vect_type) :: x + + me = this_image() + np = this%getNumImages() + call prepare_test8imgs_tran_b(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_zhalo_tran_8imgs_m_b + +end module test_psb_zhalo +