From 37b2c9a78d2838ebda13b639d2833bbc3e1318d1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 11 May 2012 18:37:51 +0000 Subject: [PATCH] Added dependecies on i_vect_mod. --- base/comm/psb_igather.f90 | 118 ++++++++++++++++++++++++++++++ base/modules/Makefile | 2 +- base/modules/psb_d_linmap_mod.f90 | 13 ++++ base/modules/psb_vect_mod.f90 | 1 + 4 files changed, 133 insertions(+), 1 deletion(-) diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 80de8837..0aaded38 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -329,3 +329,121 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) return end subroutine psb_igatherv + + +subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_igather_vect + implicit none + + type(psb_i_vect_type), intent(inout) :: locx + integer(psb_ipk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_ipk_), allocatable :: llocx(:) + character(len=20) :: name, ch_err + + name='psb_igatherv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:) = izero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = llocx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = izero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine psb_igather_vect diff --git a/base/modules/Makefile b/base/modules/Makefile index a0438b4c..f4bb49c6 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -123,7 +123,7 @@ psb_c_psblas_mod.o: psb_c_vect_mod.o psb_c_mat_mod.o psb_z_psblas_mod.o: psb_z_vect_mod.o psb_z_mat_mod.o psb_psblas_mod.o: psb_s_psblas_mod.o psb_c_psblas_mod.o psb_d_psblas_mod.o psb_z_psblas_mod.o psb_s_psblas_mod.o psb_c_psblas_mod.o psb_d_psblas_mod.o psb_z_psblas_mod.o: psb_mat_mod.o psb_desc_type.o -psb_vect_mod.o: psb_d_vect_mod.o psb_s_vect_mod.o psb_c_vect_mod.o psb_z_vect_mod.o +psb_vect_mod.o: psb_i_vect_mod.o psb_d_vect_mod.o psb_s_vect_mod.o psb_c_vect_mod.o psb_z_vect_mod.o psb_comm_mod.o: psb_i_comm_mod.o psb_s_comm_mod.o psb_d_comm_mod.o psb_c_comm_mod.o psb_z_comm_mod.o psb_i_comm_mod.o: psb_i_vect_mod.o psb_desc_type.o psb_s_comm_mod.o: psb_s_vect_mod.o psb_desc_type.o psb_mat_mod.o diff --git a/base/modules/psb_d_linmap_mod.f90 b/base/modules/psb_d_linmap_mod.f90 index d48694d6..c1da0fe6 100644 --- a/base/modules/psb_d_linmap_mod.f90 +++ b/base/modules/psb_d_linmap_mod.f90 @@ -124,6 +124,19 @@ module psb_d_linmap_mod end function psb_d_linmap end interface + interface psb_linmaps + subroutine psb_d_linmaps(mapout,map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) + use psb_d_mat_mod, only : psb_dspmat_type + import :: psb_ipk_, psb_dlinmap_type, psb_desc_type + implicit none + type(psb_dlinmap_type), intent(inout) :: mapout + type(psb_desc_type), target :: desc_X, desc_Y + type(psb_dspmat_type), intent(in) :: map_X2Y, map_Y2X + integer(psb_ipk_), intent(in) :: map_kind + integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + end subroutine psb_d_linmaps + end interface + private :: d_map_sizeof, d_is_asb, d_free diff --git a/base/modules/psb_vect_mod.f90 b/base/modules/psb_vect_mod.f90 index 31b35744..77f1f65b 100644 --- a/base/modules/psb_vect_mod.f90 +++ b/base/modules/psb_vect_mod.f90 @@ -1,4 +1,5 @@ module psb_vect_mod + use psb_i_vect_mod use psb_s_vect_mod use psb_d_vect_mod use psb_c_vect_mod