fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 12:52:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

Repackaged internals for CDASB. Defined new routines to handle global

Browse Source 
to local index conversion.
This commit is contained in:
Salvatore Filippone
2006-11-28 13:44:34 +00:00
parent 77304bcc68
commit e705e76888
13 changed files with 1135 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/internals/Makefile
+5 -3
View File
@@ -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)
src/internals/avltree.c
+13 -9
View File
@@ -213,7 +213,7 @@
#include <string.h>
#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);
}
src/internals/avltree.h
-1
View File
@@ -68,4 +68,3 @@ int AVLTreeInorderTraverseWithDelims(AVLTreePtr,void*, void*, int (*)(void*,void
void (*)(void *, void *), void *);
src/internals/psi_crea_index.f90
+13 -9
View File
@@ -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)
src/internals/psi_desc_index.f90
+20 -15
View File
@@ -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
src/internals/psi_dswaptran.f90
+1 -3
View File
@@ -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
src/internals/psi_extrct_dl.f
+6 -2
View File
@@ -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
src/internals/psi_idx_cnv.f90
+405
View File
@@ -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
src/internals/psi_idx_ins_cnv.f90
+440
View File
@@ -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
src/internals/psi_iswaptran.f90
-2
View File
@@ -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
src/internals/psi_ldsc_pre_halo.f90
+175
View File
@@ -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
src/internals/psi_zswaptran.f90
+1 -9
View File
@@ -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)
src/internals/srcht.c
+56 -18
View File
@@ -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);
}