From e705e76888f89cc4727dc32c1f486a173b9f1b04 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 28 Nov 2006 13:44:34 +0000 Subject: [PATCH] Repackaged internals for CDASB. Defined new routines to handle global to local index conversion. --- src/internals/Makefile | 8 +- src/internals/avltree.c | 22 +- src/internals/avltree.h | 1 - src/internals/psi_crea_index.f90 | 22 +- src/internals/psi_desc_index.f90 | 35 ++- src/internals/psi_dswaptran.f90 | 4 +- src/internals/psi_extrct_dl.f | 8 +- src/internals/psi_idx_cnv.f90 | 405 +++++++++++++++++++++++++ src/internals/psi_idx_ins_cnv.f90 | 440 ++++++++++++++++++++++++++++ src/internals/psi_iswaptran.f90 | 2 - src/internals/psi_ldsc_pre_halo.f90 | 175 +++++++++++ src/internals/psi_zswaptran.f90 | 10 +- src/internals/srcht.c | 74 +++-- 13 files changed, 1135 insertions(+), 71 deletions(-) create mode 100644 src/internals/psi_idx_cnv.f90 create mode 100644 src/internals/psi_idx_ins_cnv.f90 create mode 100644 src/internals/psi_ldsc_pre_halo.f90 diff --git a/src/internals/Makefile b/src/internals/Makefile index 08c868ae..ecab9a09 100644 --- a/src/internals/Makefile +++ b/src/internals/Makefile @@ -1,9 +1,11 @@ include ../../Make.inc FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ - psi_crea_ovr_elem.o psi_dl_check.o \ + psi_crea_ovr_elem.o psi_dl_check.o \ psi_gthsct.o \ - psi_sort_dl.o + psi_sort_dl.o \ + psi_gthsct.o psi_ldsc_pre_halo.o\ + psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o psi_fnd_owner.o FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o COBJS = avltree.o srcht.o @@ -16,7 +18,7 @@ LIBDIR = ../../lib lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) \ - $(COBJS) + $(COBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) diff --git a/src/internals/avltree.c b/src/internals/avltree.c index 7dc114ae..7ccf4b17 100644 --- a/src/internals/avltree.c +++ b/src/internals/avltree.c @@ -213,7 +213,7 @@ #include #include "avltree.h" -#define POOLSIZE 4096 +#define POOLSIZE 1024 #define MAXSTACK 64 #define MAX(a,b) ((a)>=(b) ? (a) : (b)) @@ -257,12 +257,12 @@ int AVLTreeInit(AVLTreePtr Tree) return(-2); } - if ((current=(AVLTVectPtr)malloc(sizeof(AVLTVect)))==NULL) { - fprintf(stderr,"Memory allocation failure\n"); - return(-3); - } - memset(current,'\0',sizeof(AVLTVect)); - Tree->first=Tree->current=current; +/* if ((current=(AVLTVectPtr)malloc(sizeof(AVLTVect)))==NULL) { */ +/* fprintf(stderr,"Memory allocation failure\n"); */ +/* return(-3); */ +/* } */ +/* memset(current,'\0',sizeof(AVLTVect)); */ + Tree->first=Tree->current=NULL; Tree->nnodes=0; Tree->root=NULL; return(0); @@ -496,7 +496,12 @@ AVLNodePtr GetAVLNode(AVLTreePtr Tree) return(NULL); } if ((current=Tree->current)==NULL) { - return(NULL); + if ((current=(AVLTVectPtr)malloc(sizeof(AVLTVect)))==NULL) { + fprintf(stderr,"Memory allocation failure\n"); + return(NULL); + } + memset(current,'\0',sizeof(AVLTVect)); + Tree->first=Tree->current=current; } while ((current->avail>=POOLSIZE)&&(current->next!=NULL)) @@ -814,4 +819,3 @@ AVLNodePtr AVLTreeUserInsert(AVLTreePtr Tree, void *key, return(q); } - diff --git a/src/internals/avltree.h b/src/internals/avltree.h index ed9d2138..2dc77d90 100644 --- a/src/internals/avltree.h +++ b/src/internals/avltree.h @@ -68,4 +68,3 @@ int AVLTreeInorderTraverseWithDelims(AVLTreePtr,void*, void*, int (*)(void*,void void (*)(void *, void *), void *); - diff --git a/src/internals/psi_crea_index.f90 b/src/internals/psi_crea_index.f90 index 1c4eed83..388492d0 100644 --- a/src/internals/psi_crea_index.f90 +++ b/src/internals/psi_crea_index.f90 @@ -45,7 +45,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info ! ....local scalars... integer :: ictxt, me, np, mode, err_act, dl_lda ! ...parameters... - integer, pointer :: dep_list(:,:), length_dl(:) + integer, allocatable :: dep_list(:,:), length_dl(:) integer,parameter :: root=0,no_comm=-1 logical,parameter :: debug=.false. character(len=20) :: name @@ -65,12 +65,13 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info end interface interface - subroutine psi_desc_index(desc_data,index_in,dep_list,& - & length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,& + subroutine psi_desc_index(desc,index_in,dep_list,& + & length_dl,nsnd,nrcv,desc_index,& & isglob_in,info) - integer :: desc_data(:),index_in(:),dep_list(:) - integer :: loc_to_glob(:),glob_to_loc(:) - integer, allocatable :: desc_index(:) + use psb_descriptor_type + type(psb_desc_type) :: desc + integer :: index_in(:),dep_list(:) + integer, allocatable :: desc_index(:) integer :: length_dl,nsnd,nrcv,info logical :: isglob_in end subroutine psi_desc_index @@ -101,6 +102,10 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info ! ...extract dependence list (ordered list of identifer process ! which every process must communcate with... +!!$ write(0,*) me,name,' Size of desc_in ',size(index_in) +!!$ if (size(index_in)>0) then +!!$ write(0,*) me,name,'first item ',index_in(1) +!!$ end if if (debug) write(*,*) 'crea_halo: calling extract_dep_list' mode = 1 @@ -129,9 +134,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info ! ...create desc_halo array..... if(debug) write(0,*)'in psi_crea_index calling psi_desc_index',& & size(index_out) - call psi_desc_index(desc_a%matrix_data,index_in,dep_list(1:,me),& - & length_dl(me),nsnd,nrcv,desc_a%loc_to_glob,desc_a%glob_to_loc,& - & index_out,glob_idx,info) + call psi_desc_index(desc_a,index_in,dep_list(1:,me),& + & length_dl(me),nsnd,nrcv, index_out,glob_idx,info) if(debug) write(0,*)'out of psi_desc_index',& & size(index_out) nxch = length_dl(me) diff --git a/src/internals/psi_desc_index.f90 b/src/internals/psi_desc_index.f90 index 79765485..3c146581 100644 --- a/src/internals/psi_desc_index.f90 +++ b/src/internals/psi_desc_index.f90 @@ -28,20 +28,20 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_desc_index(desc_data,index_in,dep_list,& - & length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,& - & isglob_in,info) - +subroutine psi_desc_index(desc,index_in,dep_list,& + & length_dl,nsnd,nrcv,desc_index,isglob_in,info) + use psb_descriptor_type use psb_realloc_mod use psb_error_mod use psb_const_mod use mpi use psb_penv_mod + use psi_mod, only : psi_idx_cnv implicit none ! ...array parameters..... - integer :: desc_data(:),index_in(:),dep_list(:) - integer :: loc_to_glob(:),glob_to_loc(:) + type(psb_desc_type) :: desc + integer :: index_in(:),dep_list(:) integer,allocatable :: desc_index(:) integer :: length_dl,nsnd,nrcv,info logical :: isglob_in @@ -65,8 +65,8 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& name='psi_desc_index' call psb_erractionsave(err_act) - ictxt=desc_data(psb_ctxt_) - icomm=desc_data(psb_mpi_c_) + ictxt = psb_cd_get_context(desc) + icomm = psb_cd_get_mpic(desc) call psb_info(ictxt,me,np) if (np == -1) then info = 2010 @@ -179,8 +179,9 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) end do else + do j=1, nerv - sndbuf(bsdindx(proc+1)+j) = loc_to_glob(index_in(i+j)) + sndbuf(bsdindx(proc+1)+j) = desc%loc_to_glob(index_in(i+j)) end do endif bsdindx(proc+1) = bsdindx(proc+1) + nerv @@ -222,15 +223,19 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& i = i + 1 nerv = sdsz(proc+1) desc_index(i) = nerv - do j=1, nerv - desc_index(i+j) = glob_to_loc(sndbuf(bsdindx(proc+1)+j)) - end do + call psi_idx_cnv(nerv,sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& + & desc_index(i+1:i+nerv),desc,info) +!!$ do j=1, nerv +!!$ desc_index(i+j) = glob_to_loc(sndbuf(bsdindx(proc+1)+j)) +!!$ end do i = i + nerv + 1 nesd = rvsz(proc+1) desc_index(i) = nesd - do j=1, nesd - desc_index(i+j) = glob_to_loc(rcvbuf(brvindx(proc+1)+j)) - end do + call psi_idx_cnv(nesd,rcvbuf(brvindx(proc+1)+1:brvindx(proc+1)+nesd),& + & desc_index(i+1:i+nesd),desc,info) +!!$ do j=1, nesd +!!$ desc_index(i+j) = glob_to_loc(rcvbuf(brvindx(proc+1)+j)) +!!$ end do i = i + nesd + 1 end do desc_index(i) = - 1 diff --git a/src/internals/psi_dswaptran.f90 b/src/internals/psi_dswaptran.f90 index 9519dda7..2f47d310 100644 --- a/src/internals/psi_dswaptran.f90 +++ b/src/internals/psi_dswaptran.f90 @@ -79,7 +79,6 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%matrix_data(psb_mpi_c_) swap_mpi = iand(flag,psb_swap_mpi_) /= 0 @@ -347,8 +346,6 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) end if - - if (do_recv) then pnti = 1 @@ -467,6 +464,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) if (np == -1) then info = 2010 diff --git a/src/internals/psi_extrct_dl.f b/src/internals/psi_extrct_dl.f index 5a29cda2..2a08d724 100644 --- a/src/internals/psi_extrct_dl.f +++ b/src/internals/psi_extrct_dl.f @@ -120,6 +120,7 @@ c length_dl integer array(0:np) c length_dl(i) is the length of dep_list(*,i) list use psb_penv_mod use psb_const_mod + use psb_descriptor_type implicit none include 'mpif.h' c ....scalar parameters... @@ -154,7 +155,8 @@ c .....local scalars... if (debug) write(0,*) 'extract: info ',info, + desc_data(psb_dec_type_) pointer_dep_list=1 - if (desc_data(psb_dec_type_).eq.psb_desc_bld_) then +c$$$ if (desc_data(psb_dec_type_).eq.psb_desc_bld_) then + if (psb_is_bld_dec(desc_data(psb_dec_type_))) then do while (desc_str(i).ne.-1) if (debug) write(0,*) me,' extract: looping ',i, + desc_str(i),desc_str(i+1),desc_str(i+2) @@ -195,7 +197,8 @@ c ...if not found..... endif i=i+desc_str(i+1)+2 enddo - else if (desc_data(psb_dec_type_).eq.psb_desc_upd_) then +c$$$ else if (desc_data(psb_dec_type_).eq.psb_desc_upd_) then + else if (psb_is_upd_dec(desc_data(psb_dec_type_))) then do while (desc_str(i).ne.-1) if (debug) write(0,*) 'extract: looping ',i,desc_str(i) @@ -236,6 +239,7 @@ c ...if not found..... else write(0,*) 'invalid dec_type',desc_data(psb_dec_type_) info = 2020 + goto 9999 endif length_dl(me)=pointer_dep_list-1 diff --git a/src/internals/psi_idx_cnv.f90 b/src/internals/psi_idx_cnv.f90 new file mode 100644 index 00000000..a12b2528 --- /dev/null +++ b/src/internals/psi_idx_cnv.f90 @@ -0,0 +1,405 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ +subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + integer, intent(in) :: nv + integer, intent(inout) :: idxin(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + logical, intent(in), optional :: owned + interface + subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) + use psb_descriptor_type + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + logical, intent(in), optional :: owned + end subroutine psi_idx_cnv2 + end interface + integer :: i,ictxt,row,k,mglob, nglob,err + integer :: np, me, isize + integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt + integer, allocatable :: idxout(:) + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + character(len=20) :: name,ch_err + logical, pointer :: mask_(:) + logical :: owned_ + + info = 0 + name = 'psb_idx_cnv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + mglob = psb_cd_get_global_rows(desc) + nglob = psb_cd_get_global_cols(desc) + nrow = psb_cd_get_local_rows(desc) + ncol = psb_cd_get_local_cols(desc) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nv < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nv == 0) return + + + if (size(idxin) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(mask)) then + if (size(mask) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + mask_ => mask + else + allocate(mask_(nv),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + mask_ = .true. + endif + + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + endif + + allocate(idxout(nv),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + call psi_idx_cnv2(nv,idxin,idxout,desc,info,mask_,owned_) + idxin(1:nv) = idxout(1:nv) + + deallocate(idxout) + + if (.not.present(mask)) then + deallocate(mask_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psi_idx_cnv1 +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ + +subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psi_mod, only : psi_inner_cnv + implicit none + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + logical, intent(in), optional :: owned + integer :: i,ictxt,row,k,mglob, nglob,err + integer :: np, me, isize + integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + character(len=20) :: name,ch_err + logical, pointer :: mask_(:) + logical :: owned_ + + info = 0 + name = 'psb_idx_cnv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + mglob = psb_cd_get_global_rows(desc) + nglob = psb_cd_get_global_cols(desc) + nrow = psb_cd_get_local_rows(desc) + ncol = psb_cd_get_local_cols(desc) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nv < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nv == 0) return + + if (size(idxin) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(idxout) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(mask)) then + if (size(mask) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + mask_ => mask + else + allocate(mask_(nv),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + mask_ = .true. + endif + + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + endif + + + if (psb_is_large_desc(desc)) then + if (psb_is_bld_desc(desc)) then + do i = 1, nv + if (mask_(i)) then + ip = idxin(i) + if ((ip < 1 ).or.(ip>mglob)) then + idxout(i) = -1 + cycle + endif + call SearchKeyVal(desc%ptree,ip,lip,info) + if (owned_) then + if (lip<=nrow) then + idxout(i) = lip + else + idxout(i) = -1 + endif + else + idxout(i) = lip + endif + end if + enddo + else if (psb_is_asb_desc(desc)) then + if (.not.allocated(desc%hashv)) then + write(0,*) 'Inconsistent input to inner_cnv' + end if + call psi_inner_cnv(nv,idxin,idxout,hashsize,hashmask,& + & desc%hashv,desc%glb_lc) + end if + + else + + do i = 1, nv + if (mask_(i)) then + ip = idxin(i) + if ((ip < 1 ).or.(ip>mglob)) then + info = 1133 + call psb_errpush(info,name) + goto 9999 + endif + lip = desc%glob_to_loc(ip) + if (owned_) then + if (lip<=nrow) then + idxout(i) = lip + else + idxout(i) = -1 + endif + else + idxout(i) = lip + endif + end if + enddo + end if + + + if (.not.present(mask)) then + deallocate(mask_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error(ictxt) + end if + return + + +end subroutine psi_idx_cnv2 +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ +subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned) + use psb_descriptor_type + integer, intent(in) :: idxin + integer, intent(out) :: idxout + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask + logical, intent(in), optional :: owned + interface + subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) + use psb_descriptor_type + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(in) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + logical, intent(in), optional :: owned + end subroutine psi_idx_cnv2 + end interface + integer :: iout(1) + logical :: mask_, owned_ + + if (present(mask)) then + mask_ = mask + else + mask_ = .true. + endif + if (present(owned)) then + owned_ = owned + else + owned_ = .true. + endif + call psi_idx_cnv2(1,(/idxin/),iout,desc,info,(/mask_/),owned_) + idxout=iout(1) + + return + +end subroutine psi_idx_cnvs diff --git a/src/internals/psi_idx_ins_cnv.f90 b/src/internals/psi_idx_ins_cnv.f90 new file mode 100644 index 00000000..9b716d01 --- /dev/null +++ b/src/internals/psi_idx_ins_cnv.f90 @@ -0,0 +1,440 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ +subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + integer, intent(in) :: nv + integer, intent(inout) :: idxin(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + interface + subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) + use psb_descriptor_type + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + end subroutine psi_idx_ins_cnv2 + end interface + integer :: i,ictxt,row,k,mglob, nglob,err + integer :: np, me, isize + integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt + integer, allocatable :: idxout(:) + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + character(len=20) :: name,ch_err + logical, pointer :: mask_(:) + + info = 0 + name = 'psb_idx_ins_cnv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + mglob = psb_cd_get_global_rows(desc) + nglob = psb_cd_get_global_cols(desc) + nrow = psb_cd_get_local_rows(desc) + ncol = psb_cd_get_local_cols(desc) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_bld_desc(desc)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nv < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nv == 0) return + + + if (size(idxin) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(mask)) then + if (size(mask) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + mask_ => mask + else + allocate(mask_(nv),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + mask_ = .true. + endif + + allocate(idxout(nv),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + call psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask_) + idxin(1:nv) = idxout(1:nv) + + deallocate(idxout) + + if (.not.present(mask)) then + deallocate(mask_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psi_idx_ins_cnv1 +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ + +subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psi_mod + implicit none + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + integer :: i,ictxt,row,k,mglob, nglob,err + integer :: np, me, isize + integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt,il1 + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + character(len=20) :: name,ch_err + logical, pointer :: mask_(:) + + info = 0 + name = 'psb_idx_ins_cnv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + mglob = psb_cd_get_global_rows(desc) + nglob = psb_cd_get_global_cols(desc) + nrow = psb_cd_get_local_rows(desc) + ncol = psb_cd_get_local_cols(desc) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nv < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nv == 0) return + + if (size(idxin) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(idxout) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(mask)) then + if (size(mask) < nv) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + mask_ => mask + else + allocate(mask_(nv),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + mask_ = .true. + endif + + + + if (psb_is_large_desc(desc)) then + do i = 1, nv + if (mask_(i)) then + ip = idxin(i) + if ((ip < 1 ).or.(ip>mglob)) then + idxout(i) = -1 + cycle + endif + nxt = ncol + 1 + + call SearchInsKeyVal(desc%ptree,ip,nxt,lip,info) + if (info >=0) then + if (nxt == lip) then + ncol = nxt + isize = size(desc%loc_to_glob) + if (ncol > isize) then + nh = ncol + max(nv,relocsz) + call psb_realloc(nh,desc%loc_to_glob,info,pad=-1) + if (debug) write(0,*) 'done realloc ',nh + if (info /= 0) then + info=1 + ch_err='psb_realloc' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + isize = nh + endif + desc%loc_to_glob(nxt) = ip + endif + info = 0 + else + ch_err='SearchInsKeyVal' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idxout(i) = lip + else + idxout(i) = -1 + end if + enddo + + else + + if (.not.allocated(desc%halo_index)) then + allocate(desc%halo_index(relocsz)) + desc%halo_index(:) = -1 + endif + pnt_halo=1 + do while (desc%halo_index(pnt_halo) /= -1 ) + pnt_halo = pnt_halo + 1 + end do + isize = size(desc%halo_index) + + do i = 1, nv + if (mask_(i)) then + ip = idxin(i) + if ((ip < 1 ).or.(ip>mglob)) then + idxout(i) = -1 + cycle + endif + k = desc%glob_to_loc(ip) + if (k.lt.-np) then + k = k + np + k = - k - 1 + ncol = ncol + 1 + lip = ncol + desc%glob_to_loc(ip) = ncol + isize = size(desc%loc_to_glob) + if (ncol > isize) then + nh = ncol + max(nv,relocsz) + call psb_realloc(nh,desc%loc_to_glob,info,pad=-1) + if (me==0) then + if (debug) write(0,*) 'done realloc ',nh + end if + if (info /= 0) then + info=3 + ch_err='psb_realloc' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + isize = nh + endif + desc%loc_to_glob(ncol) = ip + isize = size(desc%halo_index) + if ((pnt_halo+3).gt.isize) then + nh = isize + max(nv,relocsz) + call psb_realloc(nh,desc%halo_index,info,pad=-1) + if (info /= 0) then + info=4 + ch_err='psb_realloc' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + isize = nh + endif + desc%halo_index(pnt_halo) = k + desc%halo_index(pnt_halo+1) = 1 + desc%halo_index(pnt_halo+2) = ncol + pnt_halo = pnt_halo + 3 + else + lip = k + endif + idxout(i) = lip + else + idxout(i) = -1 + end if + enddo + + end if + + desc%matrix_data(psb_n_col_) = ncol + + if (.not.present(mask)) then + deallocate(mask_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error(ictxt) + end if + return + + +end subroutine psi_idx_ins_cnv2 +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ +subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask) + use psb_descriptor_type + integer, intent(in) :: idxin + integer, intent(out) :: idxout + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask + interface + subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) + use psb_descriptor_type + integer, intent(in) :: nv, idxin(:) + integer, intent(out) :: idxout(:) + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + end subroutine psi_idx_ins_cnv2 + end interface + integer :: iout(1) + logical :: mask_ + + if (present(mask)) then + mask_ = mask + else + mask_ = .true. + endif + call psi_idx_ins_cnv2(1,(/idxin/),iout,desc,info,(/mask_/)) + idxout=iout(1) + + return + +end subroutine psi_idx_ins_cnvs diff --git a/src/internals/psi_iswaptran.f90 b/src/internals/psi_iswaptran.f90 index 6dec2017..ce1b1b52 100644 --- a/src/internals/psi_iswaptran.f90 +++ b/src/internals/psi_iswaptran.f90 @@ -79,7 +79,6 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%matrix_data(psb_mpi_c_) swap_mpi = iand(flag,psb_swap_mpi_) /= 0 @@ -350,7 +349,6 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) if (do_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 diff --git a/src/internals/psi_ldsc_pre_halo.f90 b/src/internals/psi_ldsc_pre_halo.f90 new file mode 100644 index 00000000..4dda9c78 --- /dev/null +++ b/src/internals/psi_ldsc_pre_halo.f90 @@ -0,0 +1,175 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 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. +!!$ +!!$ +subroutine psi_ldsc_pre_halo(desc,info) + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psi_mod, only : psi_fnd_owner + implicit none + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + + integer,allocatable :: helem(:),hproc(:) + integer,allocatable :: tmphl(:) + + integer :: i,j,err,np,me,lhalo,nhalo,& + & n_col, err_act, key, ih, nh, idx, nk,icomm,hsize + integer :: ictxt,n_row + logical, parameter :: debug=.false., debugwrt=.false. + character(len=20) :: name,ch_err + + info = 0 + name = 'psi_ldsc_pre_halo' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + call psb_get_mpicomm(ictxt,icomm ) + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then + write(0,*) 'Invalid input descriptor in ldsc_pre_halo' + + end if + + + nk = n_col + call psb_realloc(nk,2,desc%glb_lc,info) + if (info ==0) call psb_realloc(hashsize,desc%hashv,info,lb=0) + if (info /= 0) then + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + desc%hashv(0:hashsize) = 0 + do i=1, nk + key = desc%loc_to_glob(i) + ih = iand(key,hashmask) + desc%hashv(ih) = desc%hashv(ih) + 1 + end do + nh = desc%hashv(0) + idx = 1 + do i=1, hashsize + desc%hashv(i-1) = idx + idx = idx + nh + nh = desc%hashv(i) + end do + do i=1, nk + key = desc%loc_to_glob(i) + ih = iand(key,hashmask) + idx = desc%hashv(ih) + desc%glb_lc(idx,1) = key + desc%glb_lc(idx,2) = i + desc%hashv(ih) = desc%hashv(ih) + 1 + end do + do i = hashsize, 1, -1 + desc%hashv(i) = desc%hashv(i-1) + end do + desc%hashv(0) = 1 + do i=0, hashsize-1 + idx = desc%hashv(i) + nh = desc%hashv(i+1) - desc%hashv(i) + if (nh > 1) then + call imsrx(nh,desc%glb_lc(idx,1),desc%glb_lc(idx,2),1) + end if + end do + + nh = (n_col-n_row) + if (nh > 0) then + Allocate(helem(nh),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + do i=1, nh + helem(i) = desc%loc_to_glob(n_row+i) + end do + + call psi_fnd_owner(nh,helem,hproc,desc,info) + allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + j = 1 + do i=1,nh + tmphl(j+0) = hproc(i) + if (tmphl(j+0)<0) then + write(0,*) 'Unrecoverable error: missing proc from asb' + end if + tmphl(j+1) = 1 + tmphl(j+2) = n_row+i + j = j + 3 + end do + tmphl(j) = -1 + lhalo = j + nhalo = (lhalo-1)/3 + else + allocate(tmphl(1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + tmphl=-1 + endif + + + call psb_transfer(tmphl,desc%halo_index,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error(ictxt) + end if + return + + +end subroutine psi_ldsc_pre_halo diff --git a/src/internals/psi_zswaptran.f90 b/src/internals/psi_zswaptran.f90 index 2edf6629..084294a4 100644 --- a/src/internals/psi_zswaptran.f90 +++ b/src/internals/psi_zswaptran.f90 @@ -79,7 +79,6 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%matrix_data(psb_mpi_c_) swap_mpi = iand(flag,psb_swap_mpi_) /= 0 @@ -310,9 +309,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) pnti = pnti + nerv + nesd + 3 end do - else if (swap_send) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -324,7 +321,6 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do else if (swap_recv) then @@ -345,7 +341,6 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) end if - if (do_recv) then pnti = 1 @@ -464,6 +459,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) if (np == -1) then info = 2010 @@ -775,10 +771,6 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) diff --git a/src/internals/srcht.c b/src/internals/srcht.c index 0567ce7d..aca518a2 100644 --- a/src/internals/srcht.c +++ b/src/internals/srcht.c @@ -84,25 +84,28 @@ #define POOLSIZE 4096 #define CACHESIZE 16 #ifdef Add_ -#define InitPairSearchTree initpairsearchtree_ -#define FreePairSearchTree freepairsearchtree_ -#define SearchInsKeyVal searchinskeyval_ -#define SearchKeyVal searchkeyval_ -#define NPairs npairs_ +#define InitPairSearchTree initpairsearchtree_ +#define FreePairSearchTree freepairsearchtree_ +#define ClonePairSearchTree clonepairsearchtree_ +#define SearchInsKeyVal searchinskeyval_ +#define SearchKeyVal searchkeyval_ +#define NPairs npairs_ #endif #ifdef AddDouble_ -#define InitPairSearchTree initpairsearchtree_ -#define FreePairSearchTree freepairsearchtree_ -#define SearchInsKeyVal searchinskeyval_ -#define SearchKeyVal searchkeyval_ -#define NPairs npairs_ +#define InitPairSearchTree initpairsearchtree_ +#define FreePairSearchTree freepairsearchtree_ +#define ClonePairSearchTree clonepairsearchtree_ +#define SearchInsKeyVal searchinskeyval_ +#define SearchKeyVal searchkeyval_ +#define NPairs npairs_ #endif #ifdef NoChange -#define InitPairSearchTree initpairsearchtree -#define FreePairSearchTree freepairsearchtree -#define SearchInsKeyVal searchinskeyval -#define SearchKeyVal searchkeyval -#define NPairs npairs +#define InitPairSearchTree initpairsearchtree +#define FreePairSearchTree freepairsearchtree +#define ClonePairSearchTree clonepairsearchtree +#define SearchInsKeyVal searchinskeyval +#define SearchKeyVal searchkeyval +#define NPairs npairs #endif @@ -197,7 +200,6 @@ void KeyUpdate( void *key1, void *key2, void *data) *((int *) data)=((KeyPairPtr) key2)->val; } - void FreePairSearchTree(fptr *ftree) { PairTreePtr PTree; @@ -294,13 +296,14 @@ void SearchInsKeyVal(fptr *ftree, int *key, int *val, int *res, int *iret) info = AVLTreeInsert(PTree->tree,node,CompareKeys,KeyUpdate,&(PTree->retval)); *iret = info; + if (info==0) { *res = node->val; AdvanceKeyPair(PTree->PairPoolCrt); } else if (info == 1) { *res = PTree->retval; } - return; + } @@ -335,7 +338,7 @@ void SearchKeyVal(fptr *ftree, int *key, int *res, int *iret) node.key=*key; if ((noderes = AVLTreeSearch(PTree->tree,&node,CompareKeys))==NULL) { *res = -1; - *iret = -1; + *iret = 0; } else { result = (KeyPairPtr) noderes->key; *res = result->val; @@ -353,4 +356,39 @@ void SearchKeyVal(fptr *ftree, int *key, int *res, int *iret) *iret = PTree->tree->nsteps; #endif return; +} + +void PairTreeVisit(AVLNodePtr current, PairTreePtr PTree) +{ + KeyPairPtr node,inode; + int info,i; + + if (current==NULL) return; + inode = (KeyPairPtr) current->key; + node = GetKeyPair(&(PTree->PairPoolCrt)); + node->key = inode->key; + node->val = inode->val; + info = AVLTreeInsert(PTree->tree,node,CompareKeys,KeyUpdate,&(PTree->retval)); + if (info==0) { + AdvanceKeyPair(PTree->PairPoolCrt); + } + PairTreeVisit(current->llink,PTree); + PairTreeVisit(current->rlink,PTree); +} + +void ClonePairSearchTree(fptr *ftreein, fptr *ftreeout) +{ + PairTreePtr PTreein, PTreeout; + int i,j; + AVLNodePtr nodept; + + PTreein = (PairTreePtr) *ftreein; + + if (PTreein == NULL) { + *ftreeout = (fptr) NULL; + return; + } + InitPairSearchTree(ftreeout,&i); + PTreeout = (PairTreePtr) *ftreeout; + PairTreeVisit(PTreein->tree->root,PTreeout); }