From bb0434a1a10e5aec889467719c4a28ad25133c66 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 3 Nov 2010 10:27:10 +0000 Subject: [PATCH] psblas3: base/comm/Makefile base/comm/psb_cspgather.F90 base/comm/psb_sspgather.F90 base/comm/psb_zspgather.F90 base/modules/psb_comm_mod.f90 test/serial/d_matgen.f03 Added sp_gather interfaces. --- base/comm/Makefile | 2 +- base/comm/psb_cspgather.F90 | 114 ++++++++++++++++++++++++++++++++++ base/comm/psb_sspgather.F90 | 114 ++++++++++++++++++++++++++++++++++ base/comm/psb_zspgather.F90 | 114 ++++++++++++++++++++++++++++++++++ base/modules/psb_comm_mod.f90 | 33 ++++++++++ test/serial/d_matgen.f03 | 14 ++--- 6 files changed, 382 insertions(+), 9 deletions(-) create mode 100644 base/comm/psb_cspgather.F90 create mode 100644 base/comm/psb_sspgather.F90 create mode 100644 base/comm/psb_zspgather.F90 diff --git a/base/comm/Makefile b/base/comm/Makefile index ee99c2d7..fe2a96ec 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -8,7 +8,7 @@ OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ MPFOBJS=psb_dscatter.o psb_zscatter.o psb_iscatter.o psb_cscatter.o psb_sscatter.o\ - psb_dspgather.o + psb_dspgather.o psb_sspgather.o psb_zspgather.o psb_cspgather.o LIBDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG). diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 new file mode 100644 index 00000000..d4e2e04f --- /dev/null +++ b/base/comm/psb_cspgather.F90 @@ -0,0 +1,114 @@ +subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_descriptor_type + use psb_error_mod + use psb_mat_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_cspmat_type), intent(inout) :: loca + type(psb_cspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo + integer :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer :: ip, ndx,naggrm1,naggrp1, i, j, k + logical :: keepnum_, keeploc_ + integer, allocatable :: nzbr(:), idisp(:) + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_gather' + if (psb_get_errstatus().ne.0) return + info=psb_success_ + + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = psb_cd_get_global_rows(desc_a) + ncg = psb_cd_get_global_rows(desc_a) + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + call loca%mv_to(loc_coo) + nzbr(:) = 0 + nzbr(me+1) = loc_coo%get_nzeros() + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,& + & glob_coo%val,nzbr,idisp,& + & mpi_double_precision,icomm,info) + if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,& + & glob_coo%ia,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,& + & glob_coo%ja,nzbr,idisp,& + & mpi_integer,icomm,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + if (keeploc_) then + call loca%mv_from(loc_coo) + else + call loc_coo%free() + end if + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_csp_allgather diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 new file mode 100644 index 00000000..09b23e15 --- /dev/null +++ b/base/comm/psb_sspgather.F90 @@ -0,0 +1,114 @@ +subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_descriptor_type + use psb_error_mod + use psb_mat_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_sspmat_type), intent(inout) :: loca + type(psb_sspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo + integer :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer :: ip, ndx,naggrm1,naggrp1, i, j, k + logical :: keepnum_, keeploc_ + integer, allocatable :: nzbr(:), idisp(:) + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_gather' + if (psb_get_errstatus().ne.0) return + info=psb_success_ + + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = psb_cd_get_global_rows(desc_a) + ncg = psb_cd_get_global_rows(desc_a) + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + call loca%mv_to(loc_coo) + nzbr(:) = 0 + nzbr(me+1) = loc_coo%get_nzeros() + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,mpi_real,& + & glob_coo%val,nzbr,idisp,& + & mpi_double_precision,icomm,info) + if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,& + & glob_coo%ia,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,& + & glob_coo%ja,nzbr,idisp,& + & mpi_integer,icomm,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + if (keeploc_) then + call loca%mv_from(loc_coo) + else + call loc_coo%free() + end if + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_ssp_allgather diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 new file mode 100644 index 00000000..58a5d30b --- /dev/null +++ b/base/comm/psb_zspgather.F90 @@ -0,0 +1,114 @@ +subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_descriptor_type + use psb_error_mod + use psb_mat_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_zspmat_type), intent(inout) :: loca + type(psb_zspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo + integer :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg + integer :: ip, ndx,naggrm1,naggrp1, i, j, k + logical :: keepnum_, keeploc_ + integer, allocatable :: nzbr(:), idisp(:) + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_gather' + if (psb_get_errstatus().ne.0) return + info=psb_success_ + + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = psb_cd_get_global_rows(desc_a) + ncg = psb_cd_get_global_rows(desc_a) + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& + & a_err='integer') + goto 9999 + end if + call loca%mv_to(loc_coo) + nzbr(:) = 0 + nzbr(me+1) = loc_coo%get_nzeros() + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,mpi_double_complex,& + & glob_coo%val,nzbr,idisp,& + & mpi_double_precision,icomm,info) + if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,& + & glob_coo%ia,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,& + & glob_coo%ja,nzbr,idisp,& + & mpi_integer,icomm,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + + if (keeploc_) then + call loca%mv_from(loc_coo) + else + call loc_coo%free() + end if + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_zsp_allgather diff --git a/base/modules/psb_comm_mod.f90 b/base/modules/psb_comm_mod.f90 index a6a02c8a..f8fc6168 100644 --- a/base/modules/psb_comm_mod.f90 +++ b/base/modules/psb_comm_mod.f90 @@ -313,6 +313,39 @@ module psb_comm_mod integer, intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_dsp_allgather + subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_descriptor_type + use psb_mat_mod + implicit none + type(psb_sspmat_type), intent(inout) :: loca + type(psb_sspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_ssp_allgather + subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_descriptor_type + use psb_mat_mod + implicit none + type(psb_zspmat_type), intent(inout) :: loca + type(psb_zspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_zsp_allgather + subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_descriptor_type + use psb_mat_mod + implicit none + type(psb_cspmat_type), intent(inout) :: loca + type(psb_cspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_csp_allgather subroutine psb_igatherm(globx, locx, desc_a, info, root) use psb_descriptor_type integer, intent(in) :: locx(:,:) diff --git a/test/serial/d_matgen.f03 b/test/serial/d_matgen.f03 index 31832377..6fe7da0d 100644 --- a/test/serial/d_matgen.f03 +++ b/test/serial/d_matgen.f03 @@ -1,11 +1,10 @@ ! program d_matgen use psb_sparse_mod -!!$ use psb_prec_mod -!!$ use psb_krylov_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod use psb_d_mat_mod + use psb_d_cxx_mat_mod implicit none ! input parameters @@ -31,6 +30,7 @@ program d_matgen integer :: iter, itmax,itrace, istopc, irst integer(psb_long_int_k_) :: amatsize, precsize, descsize real(psb_dpk_) :: err, eps + class(psb_d_cxx_sparse_mat), allocatable :: acxx ! other variables integer :: info, err_act @@ -61,7 +61,7 @@ program d_matgen ! call psb_barrier(ictxt) t1 = psb_wtime() - call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) + call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info,acxx) call psb_barrier(ictxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then @@ -121,7 +121,7 @@ contains ! subroutine to allocate and fill in the coefficient matrix and ! the rhs. ! - subroutine create_matrix(idim,a,b,xv,desc_a,ictxt,afmt,info) + subroutine create_matrix(idim,a,b,xv,desc_a,ictxt,afmt,info,mold) ! ! discretize the partial diferential equation ! @@ -139,12 +139,12 @@ contains ! Note that if a1=a2=a3=a4=0., the PDE is the well-known Laplace equation. ! use psb_sparse_mod - use psb_d_cxx_mat_mod implicit none integer :: idim integer, parameter :: nb=20 real(psb_dpk_), allocatable :: b(:),xv(:) type(psb_desc_type) :: desc_a + class(psb_d_base_sparse_mat), allocatable :: mold integer :: ictxt, info character :: afmt*5 type(psb_dspmat_type) :: a @@ -158,7 +158,6 @@ contains type(psb_dspmat_type) :: a_n class(psb_d_coo_sparse_mat), allocatable :: acoo class(psb_d_csr_sparse_mat), allocatable :: acsr - class(psb_d_cxx_sparse_mat), allocatable :: acxx ! deltah dimension of each grid cell ! deltat discretization time real(psb_dpk_) :: deltah, anorm @@ -170,7 +169,6 @@ contains character(len=20) :: name, ch_err - allocate(psb_d_cxx_sparse_mat :: acxx) allocate(psb_d_csr_sparse_mat :: acsr) info = psb_success_ name = 'create_matrix' @@ -373,7 +371,7 @@ contains end if !!$ call a_n%print(19) t1 = psb_wtime() - call a_n%cscnv(info,mold=acxx) + call a_n%cscnv(info,mold=mold) if(info /= psb_success_) then info=psb_err_from_subroutine_