From 0089d916b1e92d0eaa8b507ae1983304d0a58afc Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 18 Feb 2008 15:06:32 +0000 Subject: [PATCH] psblas2-dev: base/modules/psb_desc_type.f90 base/modules/psb_tools_mod.f90 base/serial/psb_dspcnv.f90 base/tools/Makefile base/tools/psb_cd_lstext.f90 base/tools/psb_dspins.f90 New inter-descriptor maps: first draft of routines allowing to build a linear map from DESC_1 to DESC_2 --- base/modules/psb_desc_type.f90 | 3 + base/modules/psb_tools_mod.f90 | 10 ++ base/serial/psb_dspcnv.f90 | 2 +- base/tools/Makefile | 2 +- base/tools/psb_cd_lstext.f90 | 187 +++++++++++++++++++++++++++++++++ base/tools/psb_dspins.f90 | 164 ++++++++++++++++++++++++++++- 6 files changed, 364 insertions(+), 4 deletions(-) create mode 100644 base/tools/psb_cd_lstext.f90 diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 41996387..7d92ef4a 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -352,6 +352,9 @@ module psb_descriptor_type !!$ end subroutine psb_cdtransfer end interface + interface psb_cd_reinit + module procedure psb_cd_reinit + end interface interface psb_cdfree module procedure psb_cdfree diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index 6826f673..48a3ef3e 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -430,6 +430,16 @@ Module psb_tools_mod integer, intent(out) :: info logical, intent(in), optional :: rebuild end subroutine psb_dspins + subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_ar + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_dspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(kind(1.d0)), intent(in) :: val(:) + integer, intent(out) :: info + end subroutine psb_dspins_2desc subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) use psb_descriptor_type use psb_spmat_type diff --git a/base/serial/psb_dspcnv.f90 b/base/serial/psb_dspcnv.f90 index e8f65273..046f2f23 100644 --- a/base/serial/psb_dspcnv.f90 +++ b/base/serial/psb_dspcnv.f90 @@ -405,7 +405,7 @@ subroutine psb_dspcnv1(a, info, afmt, upd, dupl) integer :: err_act integer :: spstate integer :: upd_, dupl_ - integer :: debug_level, debug_unit + integer :: debug_level, debug_unit character(len=20) :: name, ch_err info = 0 diff --git a/base/tools/Makefile b/base/tools/Makefile index eb58bcf0..4a0aa822 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -3,7 +3,7 @@ include ../../Make.inc FOBJS = psb_dallc.o psb_dasb.o psb_cdprt.o \ psb_dfree.o psb_dins.o \ psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o \ - psb_cdren.o psb_cdrep.o psb_get_overlap.o\ + psb_cdren.o psb_cdrep.o psb_get_overlap.o psb_cd_lstext.o\ psb_dspalloc.o psb_dspasb.o \ psb_dspfree.o psb_dspins.o psb_dsprn.o \ psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \ diff --git a/base/tools/psb_cd_lstext.f90 b/base/tools/psb_cd_lstext.f90 new file mode 100644 index 00000000..10cecc3a --- /dev/null +++ b/base/tools/psb_cd_lstext.f90 @@ -0,0 +1,187 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_cdbldext.f90 +! +! Subroutine: psb_cdbldext +! This routine takes a matrix A with its descriptor, and builds the +! auxiliary descriptor corresponding to the number of overlap levels +! specified on input. + +Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) + + use psb_tools_mod, psb_protect_name => psb_cd_lstext + + use psb_serial_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psi_mod + + Implicit None + + ! .. Array Arguments .. + Type(psb_desc_type), Intent(in), target :: desc_a + integer, intent(in) :: in_list(:) + Type(psb_desc_type), Intent(out) :: desc_ov + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + integer, intent(in),optional :: extype + + interface + subroutine psb_icdasb(desc_a,info,ext_hv) + use psb_descriptor_type + Type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + logical, intent(in),optional :: ext_hv + end subroutine psb_icdasb + end interface + integer icomm, err_act + + ! .. Local Scalars .. + Integer :: i, j, np, me,m,nnzero,& + & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo + Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& + & n_elem_send,tot_recv,tot_elem,cntov_o,& + & counter_t,n_elem,i_ovr,jj,proc_id,isz, nl, & + & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ + + Integer, allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) + Integer,allocatable :: halo(:),works(:),workr(:),t_halo_in(:),& + & t_halo_out(:),temp(:),maskr(:) + Integer,allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + logical, allocatable, target :: lmask(:) + logical, pointer :: mask_(:) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='psb_cd_lstext' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + Call psb_info(ictxt, me, np) + + If (debug_level >= psb_debug_outer_) & + & Write(debug_unit,*) me,' ',trim(name),': start',size(in_list) + + + + m = psb_cd_get_local_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-n_row + + nl = size(in_list) + + if (present(mask)) then + if (size(mask) < nl) then + info=4010 + call psb_errpush(info,name,a_err='size of mask') + goto 9999 + end if + mask_ => mask + else + allocate(lmask(nl),stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocat lmask') + goto 9999 + end if + lmask = .true. + mask_ => lmask + end if + + if (present(extype)) then + extype_ = extype + else + extype_ = psb_ovt_xhal_ + endif + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) + if (info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':From desccpy' + + + call psb_cd_reinit(desc_ov,info) + + if (info == 0) call psb_cdins(nl,in_list,desc_ov,info,mask=mask_) + + ! At this point we have added to the halo the indices in + ! in_list. Just call icdasb forcing to use + ! the halo_index provided. This is the same routine as gets + ! called inside CDASB. + ! + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),': converting indexes' + call psb_barrier(ictxt) + end if + + call psb_icdasb(desc_ov,info,ext_hv=.true.) + + call psb_cd_set_ovl_asb(desc_ov,info) + + if (info /= 0) then + ch_err='sp_free' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_cd_lstext diff --git a/base/tools/psb_dspins.f90 b/base/tools/psb_dspins.f90 index 8a455653..a770f1f4 100644 --- a/base/tools/psb_dspins.f90 +++ b/base/tools/psb_dspins.f90 @@ -68,7 +68,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) logical, intent(in), optional :: rebuild !locals..... - integer :: nrow, err_act,mglob,ncol, spstate + integer :: nrow, err_act, ncol, spstate integer :: ictxt,np,me logical, parameter :: debug=.false. integer, parameter :: relocsz=200 @@ -82,7 +82,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) ictxt = psb_cd_get_context(desc_a) - mglob = psb_cd_get_global_rows(desc_a) call psb_info(ictxt, me, np) @@ -239,3 +238,164 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) end subroutine psb_dspins + +subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) + use psb_tools_mod, psb_protect_name => psb_dspins_2desc + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(in) :: desc_ar + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_dspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(kind(1.d0)), intent(in) :: val(:) + integer, intent(out) :: info + !locals..... + + integer :: nrow, err_act, ncol, spstate + integer :: ictxt,np,me + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + integer, allocatable :: ila(:),jla(:) + character(len=20) :: name, ch_err + + info = 0 + name = 'psb_dspins' + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_ar) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc_ar)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + if (.not.psb_is_ok_desc(desc_ac)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nz < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(ia) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(ja) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(val) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nz==0) return + + spstate = a%infoa(psb_state_) + if (psb_is_bld_desc(desc_ac)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + ila(1:nz) = ia(1:nz) + + call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_ar,info,iact='I',owned=.true.) + + call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) + + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + nrow = psb_cd_get_local_rows(desc_ar) + ncol = psb_cd_get_local_cols(desc_ac) + + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (psb_is_asb_desc(desc_ac)) then + + write(0,*) 'Why are you calling me on an assembled desc_ac?' +!!$ if (psb_is_large_desc(desc_a)) then +!!$ +!!$ allocate(ila(nz),jla(nz),stat=info) +!!$ if (info /= 0) then +!!$ ch_err='allocate' +!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ goto 9999 +!!$ end if +!!$ +!!$ ila(1:nz) = ia(1:nz) +!!$ jla(1:nz) = ja(1:nz) +!!$ call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') +!!$ call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') +!!$ nrow = psb_cd_get_local_rows(desc_a) +!!$ ncol = psb_cd_get_local_cols(desc_a) +!!$ +!!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& +!!$ & info,rebuild=rebuild_) +!!$ if (info /= 0) then +!!$ info=4010 +!!$ ch_err='psb_coins' +!!$ call psb_errpush(info,name,a_err=ch_err) +!!$ goto 9999 +!!$ end if +!!$ +!!$ else +!!$ nrow = psb_cd_get_local_rows(desc_a) +!!$ ncol = psb_cd_get_local_cols(desc_a) +!!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& +!!$ & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) +!!$ if (info /= 0) then +!!$ info=4010 +!!$ ch_err='psb_coins' +!!$ call psb_errpush(info,name,a_err=ch_err) +!!$ goto 9999 +!!$ end if +!!$ end if + else + info = 1122 + call psb_errpush(info,name) + goto 9999 + end if + + 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_dspins_2desc +