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

Merge branch 'dev-openmp' of github.com:sfilippone/psblas3 into dev-openmp

Browse Source
This commit is contained in:
Salvatore Filippone
2023-02-06 19:01:06 +01:00
parent afdbac6727 beefe9aa1a
commit fd0b1482e5
259 changed files with 23394 additions and 18849 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+4 -4
View File
@@ -4,8 +4,8 @@
*~
# header files generated
cbind/*.h
util/psb_metis_int.h
/cbind/*.h
/util/psb_metis_int.h
# Make.inc generated
/Make.inc
@@ -13,8 +13,8 @@ config.log
config.status
# generated folder
include/
#modules/
/include/
/modules/
docs/src/tmp
autom4te.cache
Changelog
+9
View File
@@ -1,5 +1,14 @@
Changelog. A lot less detailed than usual, at least for past
history.
2022/05/20: Merge changes for REMOTE build. Bump v 3.8
2022/03/28: Introduce new non-blocking collectives.
2021/06/01: New CTXT object
2021/04/20: OpenMP integration
2021/04/10: Recognize MPICXX in configure
2021/02/10: Take out precset interface, only prec%set now.
2020/09/20: New getelem function to extract vector entries
2020/07/21: Fix configure for METIS sizes
2020/06/01: reworked bild internals for descriptors
2019/12/18: New internals and algorithms for FND_OWNER, faster and less
memory hungry.
2019/07/20: New SCAN collective; improve handling of SYMmetric
LICENSE
+2 -2
View File
@@ -1,5 +1,5 @@
Parallel Sparse BLAS version 3.5
(C) Copyright 2006-2018
Parallel Sparse BLAS version 3.8
(C) Copyright 2006-2022
Salvatore Filippone
Alfredo Buttari
Makefile
+20 -12
View File
@@ -1,30 +1,38 @@
include Make.inc
all: libd based precd kryld utild cbindd
all: dirs based precd kryld utild cbindd libd
@echo "====================================="
@echo "PSBLAS libraries Compilation Successful."
based: libd
dirs:
(if test ! -d lib ; then mkdir lib; fi)
(if test ! -d include ; then mkdir include; fi; $(INSTALL_DATA) Make.inc include/Make.inc.psblas)
(if test ! -d modules ; then mkdir modules; fi;)
precd: based
utild: based
kryld: precd
cbindd: precd kryld utild
cbindd: based precd kryld utild
libd:
(if test ! -d lib ; then mkdir lib; fi)
(if test ! -d include ; then mkdir include; fi; $(INSTALL_DATA) Make.inc include/Make.inc.psblas)
(if test ! -d modules ; then mkdir modules; fi;)
based:
libd: based precd kryld utild cbindd
$(MAKE) -C base lib
precd:
$(MAKE) -C prec lib
kryld:
$(MAKE) -C krylov lib
utild:
$(MAKE) -C util lib
$(MAKE) -C cbind lib
based:
$(MAKE) -C base objs
precd:
$(MAKE) -C prec objs
kryld:
$(MAKE) -C krylov objs
utild:
$(MAKE) -C util objs
cbindd:
$(MAKE) -C cbind lib
$(MAKE) -C cbind objs
install: all
mkdir -p $(INSTALL_INCLUDEDIR) &&\
README.md
+12 -7
View File
@@ -1,4 +1,4 @@
PSBLAS library, version 3.7
PSBLAS library, version 3.8
===========================
The architecture of the Fortran 2003 sparse BLAS is described in:
@@ -25,7 +25,7 @@ Harwell-Boeing and MatrixMarket file formats.
DOCUMENTATION
-------------
See docs/psblas-3.5.pdf; an HTML version of the same document is
See docs/psblas-3.8.pdf; an HTML version of the same document is
available in docs/html. Please consult the sample programs, especially
test/pargen/psb_[sd]_pde[23]d.f90
@@ -58,7 +58,8 @@ prerequisites (see also SERIAL below):
directories but only if you specify `--with-metis`.
4. If you have the AMD package of Davis, Duff and Amestoy, you can
specify `--with-amd` (see `./configure --help` for more details).
specify `--with-amd` (see `./configure --help` for more details).
We use the C interface to AMD.
The configure script will generate a Make.inc file suitable for building
the library. The script is capable of recognizing the needed libraries
@@ -97,11 +98,15 @@ that enables running in pure serial mode; no MPI installation is needed
in this case (but note that the fake MPI stubs are only guaranteed to
cover what we use internally, it's not a complete replacement).
LONG INTEGERS
INTEGER SIZES
-------------
We have an experimental flag `--enable-long-integers` that will enable
having 8-byte integer data, allowing an index space larger than 2G; some
small cases have been tested but we do not offer full guarantee (yet).
We have two kind of integers: IPK for local indices, and LPK for
global indices. They can be specified independently at configure time,
e.g.
--with-ipk=4 --with-lpk=8
which is asking for 4-bytes local indices, and 8-bytes global indices
(this is the default).
TODO
ReleaseNews
+8
View File
@@ -1,5 +1,13 @@
WHAT'S NEW
Version 3.8.0-2
1. CTXT is now an opaque object.
2. OpenMP is now better integrated.
3. New non-blocking collectives.
4. Now allowing remote builds (i.e. local contributions can
now be sent to the final destination process)
5. Restore Makefiles to work on parallel builds.
Version 3.7.0.1
1. PREC%DESCR method now requires a mandatory INFO argument.
base/Makefile
+15 -8
View File
@@ -6,24 +6,31 @@ INCDIR=../include
MODDIR=../modules
LIBNAME=$(BASELIBNAME)
lib: mods sr cm in pb tl
objs: mods sr cm in pb tl
lib: objs
$(MAKE) -C modules lib LIBNAME=$(BASELIBNAME) F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
$(MAKE) -C serial lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C comm lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C internals lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C psblas lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C tools lib LIBNAME=$(BASELIBNAME)
/bin/cp -p $(CPUPDFLAG) $(HERE)/$(LIBNAME) $(LIBDIR)
/bin/cp -p $(CPUPDFLAG) *$(.mod) $(MODDIR)
sr cm in pb tl: mods
mods:
$(MAKE) -C modules lib LIBNAME=$(BASELIBNAME) F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
$(MAKE) -C modules objs F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
sr:
$(MAKE) -C serial lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C serial objs
cm:
$(MAKE) -C comm lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C comm objs
in:
$(MAKE) -C internals lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C internals objs
pb:
$(MAKE) -C psblas lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C psblas objs
tl:
$(MAKE) -C tools lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C tools objs
clean:
($(MAKE) -C modules clean)
base/comm/Makefile
+5 -2
View File
@@ -27,12 +27,15 @@ INCDIR=..
MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
lib: interns mpfobjs $(OBJS)
objs: interns mpfobjs $(OBJS)
lib: objs
$(MAKE) -C internals lib LIBNAME=$(LIBNAME)
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
interns:
$(MAKE) -C internals lib
$(MAKE) -C internals objs
mpfobjs:
$(MAKE) $(MPFOBJS) FC="$(MPFC)"
base/comm/internals/Makefile
+2 -1
View File
@@ -31,7 +31,8 @@ MODDIR=../../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
CINCLUDES=-I.
lib: mpfobjs $(FOBJS) $(MPFOBJS)
objs: mpfobjs $(FOBJS) $(MPFOBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
base/internals/Makefile
+2 -1
View File
@@ -16,7 +16,8 @@ MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
CINCLUDES=-I.
lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(MPFOBJS)
objs: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(MPFOBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
base/internals/psi_graph_fnd_owner.F90
+11 -10
View File
@@ -41,6 +41,8 @@
!
! iprc(:) - integer(psb_ipk_), allocatable Output: process identifiers
! for the corresponding indices
! ladj(:) - integer(psb_ipk_), allocatable Output: A list of adjacent processes
!
! idxmap - class(psb_indx_map). The index map
! info - integer. return code.
!
@@ -76,7 +78,7 @@
! thereby limiting the memory footprint to a predefined maximum
! (that the user can force with psb_cd_set_maxspace()).
!
subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
subroutine psi_graph_fnd_owner(idx,iprc,ladj,idxmap,info)
use psb_serial_mod
use psb_const_mod
use psb_error_mod
@@ -93,13 +95,13 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
include 'mpif.h'
#endif
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), allocatable, intent(out) :: iprc(:), ladj(:)
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), allocatable :: tidx(:)
integer(psb_ipk_), allocatable :: tprc(:), tsmpl(:), ladj(:)
integer(psb_ipk_), allocatable :: tprc(:), tsmpl(:)
integer(psb_mpk_) :: icomm, minfo
integer(psb_ipk_) :: i,n_row,n_col,err_act,ip,j, nsampl_out,&
& nv, n_answers, nqries, nsampl_in, locr_max, ist, iend,&
@@ -208,7 +210,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
if (trace.and.(me == 0)) write(0,*) ' Initial sweep on user-defined topology',&
& nsampl_in
call psi_adj_fnd_sweep(idx,iprc,ladj,idxmap,nsampl_in,n_answers)
call idxmap%xtnd_p_adjcncy(ladj)
nqries = nv - n_answers
nqries_max = nqries
call psb_max(ctxt,nqries_max)
@@ -253,13 +255,12 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
n_answers = n_answers + nlansw
nqries = nv - n_answers
!
! 3. Extract the resulting adjacency list and add it to the
! indxmap;
! 3. Extract the resulting adjacency list ? AND ADD IT TO THE EXISTING ONE ?
!
ladj = tprc(1:nlansw)
call psb_msort_unique(ladj,nadj)
call psb_realloc(nadj,ladj,info)
call idxmap%xtnd_p_adjcncy(ladj)
! call idxmap%xtnd_p_adjcncy(ladj)
if (do_timings) call psb_toc(idx_loop_a2a)
if (do_timings) call psb_tic(idx_loop_neigh)
!
@@ -368,7 +369,7 @@ contains
integer(psb_ipk_), intent(in) :: n_samples
integer(psb_ipk_), intent(inout) :: iprc(:), n_answers
integer(psb_ipk_), intent(in) :: adj(:)
class(psb_indx_map), intent(inout) :: idxmap
class(psb_indx_map), intent(in) :: idxmap
!
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: ipnt, ns_in, ns_out, n_rem, me, np, isw, n_reml,iend, nv
base/internals/psi_indx_map_fnd_owner.F90
+14 -12
View File
@@ -51,7 +51,7 @@
! 2. Check if TEMPVG(:) is allocated, and use it; or
! 3. Call the general method PSI_GRAPH_FND_OWNER.
!
subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info,adj)
use psb_serial_mod
use psb_const_mod
use psb_error_mod
@@ -66,15 +66,15 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(inout) :: idxmap
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
integer(psb_ipk_), allocatable :: hhidx(:)
integer(psb_ipk_), allocatable :: hhidx(:), ladj(:)
integer(psb_mpk_) :: icomm, minfo
integer(psb_ipk_) :: i, err_act, hsize
integer(psb_ipk_) :: i, err_act, hsize, nadj
integer(psb_lpk_) :: nv
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@@ -131,7 +131,6 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
iprc(i) = -1
end if
end do
else if (allocated(idxmap%tempvg)) then
!!$ write(0,*) me,trim(name),' indxmap%tempvg shortcut'
! Use temporary vector
@@ -183,7 +182,7 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
tidx(k2) = idx(k1)
end if
end do
call psi_graph_fnd_owner(tidx,tprc,idxmap,info)
call psi_graph_fnd_owner(tidx,tprc,ladj,idxmap,info)
k2 = 0
do k1 = 1, nv
if (iprc(k1) < 0) then
@@ -198,12 +197,15 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
end do
end block
else
call psi_graph_fnd_owner(idx,iprc,idxmap,info)
call psi_graph_fnd_owner(idx,iprc,ladj,idxmap,info)
end if
end if
if (present(adj)) then
adj = iprc
call psb_msort_unique(adj,nadj)
call psb_realloc(nadj,adj,info)
end if
if (gettime) then
call psb_barrier(ctxt)
t1 = psb_wtime()
base/modules/Makefile
+10 -7
View File
@@ -108,15 +108,18 @@ UTIL_MODS = desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\
MODULES=$(BASIC_MODS) $(SERIAL_MODS) $(UTIL_MODS)
OBJS = error.o psb_base_mod.o $(EXTRA_COBJS) cutil.o
LIBDIR=..
MODDIR=../../modules
LIBDIR=../
CINCLUDES=-I.
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). $(FIFLAG).
lib: $(LIBDIR)/$(LIBNAME)
/bin/cp -p $(CPUPDFLAG) *$(.mod) $(LIBDIR)
objs: $(MODULES) $(OBJS) $(MPFOBJS)
/bin/cp -p $(CPUPDFLAG) *$(.mod) $(MODDIR)
$(LIBDIR)/$(LIBNAME): $(MODULES) $(OBJS) $(MPFOBJS)
lib: objs $(LIBDIR)/$(LIBNAME)
$(LIBDIR)/$(LIBNAME): objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
@@ -358,8 +361,8 @@ tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o tools/psb_m_tools_a_mod.o tools/
tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\
tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o: desc/psb_desc_mod.o psi_mod.o serial/psb_mat_mod.o
tools/psb_i_tools_mod.o: serial/psb_i_vect_mod.o
tools/psb_l_tools_mod.o: serial/psb_l_vect_mod.o
tools/psb_i_tools_mod.o: serial/psb_i_vect_mod.o tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o
tools/psb_l_tools_mod.o: serial/psb_l_vect_mod.o tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o
tools/psb_s_tools_mod.o: serial/psb_s_vect_mod.o
tools/psb_d_tools_mod.o: serial/psb_d_vect_mod.o
tools/psb_c_tools_mod.o: serial/psb_c_vect_mod.o
@@ -375,7 +378,7 @@ psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o ps
psb_base_mod.o: $(MODULES)
penv/psi_penv_mod.o: penv/psi_penv_mod.F90 psb_const_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o
penv/psi_penv_mod.o: penv/psi_penv_mod.F90 psb_const_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o desc/psb_desc_const_mod.o
$(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@
psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS)
base/modules/auxil/psb_c_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
complex(psb_spk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
complex(psb_spk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_c_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/auxil/psb_d_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
real(psb_dpk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
real(psb_dpk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_d_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/auxil/psb_e_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
integer(psb_epk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
integer(psb_epk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_e_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/auxil/psb_i2_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
integer(psb_i2pk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
integer(psb_i2pk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_i2_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/auxil/psb_i_sort_mod.f90
-578
View File
@@ -1,578 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_i_sort_mod
use psb_const_mod
interface psb_isaperm
logical function psb_iisaperm(n,eip)
import
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: eip(n)
end function psb_iisaperm
end interface psb_isaperm
interface psb_msort_unique
subroutine psb_imsort_u(x,nout,dir)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_imsort_u
end interface psb_msort_unique
type psb_i_heap
integer(psb_ipk_) :: last, dir
integer(psb_ipk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_i_init_heap
procedure, pass(heap) :: howmany => psb_i_howmany
procedure, pass(heap) :: insert => psb_i_insert_heap
procedure, pass(heap) :: get_first => psb_i_heap_get_first
procedure, pass(heap) :: dump => psb_i_dump_heap
procedure, pass(heap) :: free => psb_i_free_heap
end type psb_i_heap
type psb_i_idx_heap
integer(psb_ipk_) :: last, dir
integer(psb_ipk_), allocatable :: keys(:)
integer(psb_ipk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_i_idx_init_heap
procedure, pass(heap) :: howmany => psb_i_idx_howmany
procedure, pass(heap) :: insert => psb_i_idx_insert_heap
procedure, pass(heap) :: get_first => psb_i_idx_heap_get_first
procedure, pass(heap) :: dump => psb_i_idx_dump_heap
procedure, pass(heap) :: free => psb_i_idx_free_heap
end type psb_i_idx_heap
interface psb_msort
subroutine psb_imsort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_imsort
end interface psb_msort
interface psb_bsrch
function psb_ibsrch(key,n,v) result(ipos)
import
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
end function psb_ibsrch
end interface psb_bsrch
interface psb_ssrch
function psb_issrch(key,n,v) result(ipos)
import
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
end function psb_issrch
end interface psb_ssrch
interface
subroutine psi_i_msort_up(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i_msort_up
subroutine psi_i_msort_dw(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i_msort_dw
end interface
interface
subroutine psi_i_amsort_up(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i_amsort_up
subroutine psi_i_amsort_dw(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i_amsort_dw
end interface
interface psb_qsort
subroutine psb_iqsort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_iqsort
end interface psb_qsort
interface psb_isort
subroutine psb_iisort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_iisort
end interface psb_isort
interface psb_hsort
subroutine psb_ihsort(x,ix,dir,flag)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_ihsort
end interface psb_hsort
interface
subroutine psi_i_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_insert_heap
end interface
interface
subroutine psi_i_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_idx_insert_heap
end interface
interface
subroutine psi_i_heap_get_first(key,last,heap,dir,info)
import
implicit none
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_heap_get_first
end interface
interface
subroutine psi_i_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_idx_heap_get_first
end interface
interface
subroutine psi_iisrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisrx_up
subroutine psi_iisrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisrx_dw
subroutine psi_iisr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisr_up
subroutine psi_iisr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iisr_dw
subroutine psi_iaisrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisrx_up
subroutine psi_iaisrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisrx_dw
subroutine psi_iaisr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisr_up
subroutine psi_iaisr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaisr_dw
end interface
interface
subroutine psi_iqsrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsrx_up
subroutine psi_iqsrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsrx_dw
subroutine psi_iqsr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsr_up
subroutine psi_iqsr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iqsr_dw
subroutine psi_iaqsrx_up(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsrx_up
subroutine psi_iaqsrx_dw(n,x,ix)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsrx_dw
subroutine psi_iaqsr_up(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsr_up
subroutine psi_iaqsr_dw(n,x)
import
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_iaqsr_dw
end interface
contains
subroutine psb_i_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_i_init_heap
function psb_i_howmany(heap) result(res)
implicit none
class(psb_i_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_i_howmany
subroutine psb_i_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
integer(psb_ipk_), intent(in) :: key
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_i_insert_heap(key,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_i_insert_heap
subroutine psb_i_heap_get_first(key,heap,info)
implicit none
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: key
info = psb_success_
call psi_i_heap_get_first(key,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_i_heap_get_first
subroutine psb_i_dump_heap(iout,heap,info)
implicit none
class(psb_i_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_i_dump_heap
subroutine psb_i_free_heap(heap,info)
implicit none
class(psb_i_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_i_free_heap
subroutine psb_i_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_i_idx_init_heap
function psb_i_idx_howmany(heap) result(res)
implicit none
class(psb_i_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_i_idx_howmany
subroutine psb_i_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_i_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_i_idx_insert_heap
subroutine psb_i_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: key
info = psb_success_
call psi_i_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_i_idx_heap_get_first
subroutine psb_i_idx_dump_heap(iout,heap,info)
implicit none
class(psb_i_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_i_idx_dump_heap
subroutine psb_i_idx_free_heap(heap,info)
implicit none
class(psb_i_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_i_idx_free_heap
end module psb_i_sort_mod
base/modules/auxil/psb_l_sort_mod.f90
-578
View File
@@ -1,578 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! Sorting routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
module psb_l_sort_mod
use psb_const_mod
interface psb_isaperm
logical function psb_lisaperm(n,eip)
import
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_), intent(in) :: eip(n)
end function psb_lisaperm
end interface psb_isaperm
interface psb_msort_unique
subroutine psb_lmsort_u(x,nout,dir)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_lmsort_u
end interface psb_msort_unique
type psb_l_heap
integer(psb_ipk_) :: last, dir
integer(psb_lpk_), allocatable :: keys(:)
contains
procedure, pass(heap) :: init => psb_l_init_heap
procedure, pass(heap) :: howmany => psb_l_howmany
procedure, pass(heap) :: insert => psb_l_insert_heap
procedure, pass(heap) :: get_first => psb_l_heap_get_first
procedure, pass(heap) :: dump => psb_l_dump_heap
procedure, pass(heap) :: free => psb_l_free_heap
end type psb_l_heap
type psb_l_idx_heap
integer(psb_ipk_) :: last, dir
integer(psb_lpk_), allocatable :: keys(:)
integer(psb_lpk_), allocatable :: idxs(:)
contains
procedure, pass(heap) :: init => psb_l_idx_init_heap
procedure, pass(heap) :: howmany => psb_l_idx_howmany
procedure, pass(heap) :: insert => psb_l_idx_insert_heap
procedure, pass(heap) :: get_first => psb_l_idx_heap_get_first
procedure, pass(heap) :: dump => psb_l_idx_dump_heap
procedure, pass(heap) :: free => psb_l_idx_free_heap
end type psb_l_idx_heap
interface psb_msort
subroutine psb_lmsort(x,ix,dir,flag)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
end subroutine psb_lmsort
end interface psb_msort
interface psb_bsrch
function psb_lbsrch(key,n,v) result(ipos)
import
integer(psb_ipk_) :: ipos, n
integer(psb_lpk_) :: key
integer(psb_lpk_) :: v(:)
end function psb_lbsrch
end interface psb_bsrch
interface psb_ssrch
function psb_lssrch(key,n,v) result(ipos)
import
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_lpk_) :: key
integer(psb_lpk_) :: v(:)
end function psb_lssrch
end interface psb_ssrch
interface
subroutine psi_l_msort_up(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
end subroutine psi_l_msort_up
subroutine psi_l_msort_dw(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
end subroutine psi_l_msort_dw
end interface
interface
subroutine psi_l_amsort_up(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
end subroutine psi_l_amsort_up
subroutine psi_l_amsort_dw(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
end subroutine psi_l_amsort_dw
end interface
interface psb_qsort
subroutine psb_lqsort(x,ix,dir,flag)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
end subroutine psb_lqsort
end interface psb_qsort
interface psb_isort
subroutine psb_lisort(x,ix,dir,flag)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
end subroutine psb_lisort
end interface psb_isort
interface psb_hsort
subroutine psb_lhsort(x,ix,dir,flag)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
end subroutine psb_lhsort
end interface psb_hsort
interface
subroutine psi_l_insert_heap(key,last,heap,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_lpk_), intent(in) :: key
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_l_insert_heap
end interface
interface
subroutine psi_l_idx_insert_heap(key,index,last,heap,idxs,dir,info)
import
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_lpk_), intent(in) :: key
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_lpk_), intent(in) :: index
integer(psb_ipk_), intent(in) :: dir
integer(psb_lpk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_l_idx_insert_heap
end interface
interface
subroutine psi_l_heap_get_first(key,last,heap,dir,info)
import
implicit none
integer(psb_lpk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_l_heap_get_first
end interface
interface
subroutine psi_l_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
integer(psb_lpk_), intent(inout) :: key
integer(psb_lpk_), intent(out) :: index
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_lpk_), intent(inout) :: idxs(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_l_idx_heap_get_first
end interface
interface
subroutine psi_lisrx_up(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lisrx_up
subroutine psi_lisrx_dw(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lisrx_dw
subroutine psi_lisr_up(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lisr_up
subroutine psi_lisr_dw(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lisr_dw
subroutine psi_laisrx_up(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laisrx_up
subroutine psi_laisrx_dw(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laisrx_dw
subroutine psi_laisr_up(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laisr_up
subroutine psi_laisr_dw(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laisr_dw
end interface
interface
subroutine psi_lqsrx_up(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lqsrx_up
subroutine psi_lqsrx_dw(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lqsrx_dw
subroutine psi_lqsr_up(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lqsr_up
subroutine psi_lqsr_dw(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_lqsr_dw
subroutine psi_laqsrx_up(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laqsrx_up
subroutine psi_laqsrx_dw(n,x,ix)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: ix(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laqsrx_dw
subroutine psi_laqsr_up(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laqsr_up
subroutine psi_laqsr_dw(n,x)
import
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
end subroutine psi_laqsr_dw
end interface
contains
subroutine psb_l_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_l_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
return
end subroutine psb_l_init_heap
function psb_l_howmany(heap) result(res)
implicit none
class(psb_l_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_l_howmany
subroutine psb_l_insert_heap(key,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
integer(psb_lpk_), intent(in) :: key
class(psb_l_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_l_insert_heap(key,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_l_insert_heap
subroutine psb_l_heap_get_first(key,heap,info)
implicit none
class(psb_l_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(out) :: key
info = psb_success_
call psi_l_heap_get_first(key,&
& heap%last,heap%keys,heap%dir,info)
return
end subroutine psb_l_heap_get_first
subroutine psb_l_dump_heap(iout,heap,info)
implicit none
class(psb_l_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
end if
end subroutine psb_l_dump_heap
subroutine psb_l_free_heap(heap,info)
implicit none
class(psb_l_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
end subroutine psb_l_free_heap
subroutine psb_l_idx_init_heap(heap,info,dir)
use psb_realloc_mod, only : psb_ensure_size
implicit none
class(psb_l_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: dir
info = psb_success_
heap%last=0
if (present(dir)) then
heap%dir = dir
else
heap%dir = psb_sort_up_
endif
select case(heap%dir)
case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_)
! ok, do nothing
case default
write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_'
heap%dir = psb_sort_up_
end select
call psb_ensure_size(psb_heap_resize,heap%keys,info)
call psb_ensure_size(psb_heap_resize,heap%idxs,info)
return
end subroutine psb_l_idx_init_heap
function psb_l_idx_howmany(heap) result(res)
implicit none
class(psb_l_idx_heap), intent(in) :: heap
integer(psb_ipk_) :: res
res = heap%last
end function psb_l_idx_howmany
subroutine psb_l_idx_insert_heap(key,index,heap,info)
use psb_realloc_mod, only : psb_ensure_size
implicit none
integer(psb_lpk_), intent(in) :: key
integer(psb_lpk_), intent(in) :: index
class(psb_l_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info = psb_success_
if (heap%last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',heap%last
info = heap%last
return
endif
call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize)
if (info == psb_success_) &
& call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Memory allocation failure in heap_insert'
info = -5
return
end if
call psi_l_idx_insert_heap(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_l_idx_insert_heap
subroutine psb_l_idx_heap_get_first(key,index,heap,info)
implicit none
class(psb_l_idx_heap), intent(inout) :: heap
integer(psb_lpk_), intent(out) :: index
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(out) :: key
info = psb_success_
call psi_l_idx_heap_get_first(key,index,&
& heap%last,heap%keys,heap%idxs,heap%dir,info)
return
end subroutine psb_l_idx_heap_get_first
subroutine psb_l_idx_dump_heap(iout,heap,info)
implicit none
class(psb_l_idx_heap), intent(in) :: heap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iout
info = psb_success_
if (iout < 0) then
write(psb_err_unit,*) 'Invalid file '
info =-1
return
end if
write(iout,*) 'Heap direction ',heap%dir
write(iout,*) 'Heap size ',heap%last
if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.&
& (size(heap%keys)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else if ((heap%last > 0).and.((.not.allocated(heap%idxs)).or.&
& (size(heap%idxs)<heap%last))) then
write(iout,*) 'Inconsistent size/allocation status!!'
else
write(iout,*) heap%keys(1:heap%last)
write(iout,*) heap%idxs(1:heap%last)
end if
end subroutine psb_l_idx_dump_heap
subroutine psb_l_idx_free_heap(heap,info)
implicit none
class(psb_l_idx_heap), intent(inout) :: heap
integer(psb_ipk_), intent(out) :: info
info=psb_success_
if (allocated(heap%keys)) deallocate(heap%keys,stat=info)
if ((info == psb_success_).and.(allocated(heap%idxs))) deallocate(heap%idxs,stat=info)
end subroutine psb_l_idx_free_heap
end module psb_l_sort_mod
base/modules/auxil/psb_m_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
integer(psb_mpk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
integer(psb_mpk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_m_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/auxil/psb_s_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
real(psb_spk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
real(psb_spk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_s_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/auxil/psb_z_realloc_mod.F90
+14 -5
View File
@@ -131,7 +131,7 @@ Contains
! ...Local Variables
complex(psb_dpk_),allocatable :: tmp(:)
integer(psb_mpk_) :: dim, lb_, lbi,ub_
integer(psb_mpk_) :: dim, lb_, lbi,ub_, i
integer(psb_ipk_) :: err_act,err
character(len=30) :: name
logical, parameter :: debug=.false.
@@ -179,7 +179,10 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad
!$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad
end do
endif
call psb_erractionrestore(err_act)
return
@@ -204,7 +207,7 @@ Contains
complex(psb_dpk_),allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act,err
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2
integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2, i
character(len=30) :: name
name='psb_r_m_z_rk2'
@@ -267,8 +270,14 @@ Contains
end if
endif
if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
!$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad
end do
!$omp parallel do private(i) shared(lb1_,dim,len1,lb2_,dim2,len2)
do i=lb1_,lb1_-1+len1
rrax(i,lb2_-1+dim2+1:lb2_-1+len2) = pad
end do
endif
call psb_erractionrestore(err_act)
return
base/modules/desc/psb_desc_const_mod.f90
+3
View File
@@ -48,6 +48,9 @@ module psb_desc_const_mod
! The following are bit fields.
integer(psb_ipk_), parameter :: psb_swap_send_=1, psb_swap_recv_=2
integer(psb_ipk_), parameter :: psb_swap_sync_=4, psb_swap_mpi_=8
integer(psb_ipk_), parameter :: psb_collective_start_=1, psb_collective_end_=2
integer(psb_ipk_), parameter :: psb_collective_sync_=4
! Choice among lists on which to base data exchange
integer(psb_ipk_), parameter :: psb_no_comm_=-1
integer(psb_ipk_), parameter :: psb_comm_halo_=1, psb_comm_ovr_=2
base/modules/desc/psb_gen_block_map_mod.F90
+12 -5
View File
@@ -1050,15 +1050,18 @@ contains
end subroutine block_lg2lv2_ins
subroutine block_fnd_owner(idx,iprc,idxmap,info)
subroutine block_fnd_owner(idx,iprc,idxmap,info,adj)
use psb_penv_mod
use psb_realloc_mod
use psb_sort_mod
implicit none
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_gen_block_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
class(psb_gen_block_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: iam, np, nv, ip, i
integer(psb_ipk_) :: iam, np, nv, ip, i, nadj
integer(psb_lpk_) :: tidx
ctxt = idxmap%get_ctxt()
@@ -1073,7 +1076,11 @@ contains
ip = gen_block_search(tidx-1,np+1,idxmap%vnl)
iprc(i) = ip - 1
end do
if (present(adj)) then
adj = iprc
call psb_msort_unique(adj,nadj)
call psb_realloc(nadj,adj,info)
end if
end subroutine block_fnd_owner
base/modules/desc/psb_glist_map_mod.f90
+12 -2
View File
@@ -150,16 +150,20 @@ contains
end subroutine glist_initvg
subroutine glist_fnd_owner(idx,iprc,idxmap,info)
subroutine glist_fnd_owner(idx,iprc,idxmap,info,adj)
use psb_penv_mod
use psb_sort_mod
use psb_realloc_mod
implicit none
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_glist_map), intent(inout) :: idxmap
class(psb_glist_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: nadj
integer(psb_lpk_) :: nv, i, ngp
ctxt = idxmap%get_ctxt()
@@ -180,6 +184,12 @@ contains
end if
end do
if (present(adj)) then
adj = iprc
call psb_msort_unique(adj,nadj)
call psb_realloc(nadj,adj,info)
end if
end subroutine glist_fnd_owner
function glist_get_fmt() result(res)
base/modules/desc/psb_indx_map_mod.f90
+15 -8
View File
@@ -268,13 +268,14 @@ module psb_indx_map_mod
!!
interface
subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info,adj)
import :: psb_indx_map, psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
end subroutine psi_indx_map_fnd_owner
end interface
@@ -303,13 +304,14 @@ module psb_indx_map_mod
end interface
interface
subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
subroutine psi_graph_fnd_owner(idx,iprc,ladj,idxmap,info)
import :: psb_indx_map, psb_ipk_, psb_lpk_
implicit none
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), allocatable, intent(out) :: ladj(:)
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
end subroutine psi_graph_fnd_owner
end interface
@@ -1519,7 +1521,7 @@ contains
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_indx_map), intent(inout) :: idxmap
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: xin
integer(psb_ipk_), intent(out) :: xout
integer(psb_ipk_), intent(out) :: info
@@ -1548,7 +1550,7 @@ contains
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_indx_map), intent(inout) :: idxmap
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: xin(:)
integer(psb_ipk_), intent(out) :: xout(:)
integer(psb_ipk_), intent(out) :: info
@@ -1557,6 +1559,11 @@ contains
nr = idxmap%local_rows
nc = min(idxmap%local_cols, (nr+psb_size(idxmap%halo_owner)))
sz = min(size(xin),size(xout))
if (.not.allocated(idxmap%halo_owner)) then
xout = -1
return
end if
do i = 1, sz
xout(i) = -1
if ((nr<xin(i)).and.(xin(i) <= nc)) xout(i) = idxmap%halo_owner(xin(i)-nr)
base/modules/desc/psb_repl_map_mod.f90
+7 -3
View File
@@ -696,13 +696,14 @@ contains
end subroutine repl_g2lv2_ins
subroutine repl_fnd_owner(idx,iprc,idxmap,info)
subroutine repl_fnd_owner(idx,iprc,idxmap,info,adj)
use psb_penv_mod
implicit none
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
integer(psb_ipk_) :: nv
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: iam, np
@@ -717,6 +718,9 @@ contains
return
end if
iprc(1:nv) = iam
if (present(adj)) then
adj = (/ iam /)
end if
end subroutine repl_fnd_owner
base/modules/penv/psi_c_collective_mod.F90
+602 -195
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_d_collective_mod.F90
+933 -328
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_e_collective_mod.F90
+849 -294
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_i2_collective_mod.F90
+849 -294
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_m_collective_mod.F90
+849 -294
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_s_collective_mod.F90
+933 -328
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_z_collective_mod.F90
+602 -195
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_const_mod.F90
+5 -2
View File
@@ -136,9 +136,9 @@ module psb_const_mod
!
! Version
!
character(len=*), parameter :: psb_version_string_ = "3.7.0"
character(len=*), parameter :: psb_version_string_ = "3.8.0"
integer(psb_ipk_), parameter :: psb_version_major_ = 3
integer(psb_ipk_), parameter :: psb_version_minor_ = 7
integer(psb_ipk_), parameter :: psb_version_minor_ = 8
integer(psb_ipk_), parameter :: psb_patchlevel_ = 0
!
@@ -204,6 +204,9 @@ module psb_const_mod
integer(psb_ipk_), parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer(psb_ipk_), parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
integer(psb_ipk_), parameter :: psb_matbld_noremote_=0, psb_matbld_remote_=1
integer(psb_ipk_), parameter :: psb_ireg_flgs_=10, psb_ip2_=0
integer(psb_ipk_), parameter :: psb_iflag_=2, psb_ichk_=3
integer(psb_ipk_), parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
base/modules/serial/psb_c_base_mat_mod.F90
+16 -13
View File
@@ -1865,18 +1865,10 @@ module psb_c_base_mat_mod
integer(psb_ipk_), intent(in), optional :: idir
end subroutine psb_c_fix_coo_inner
end interface
interface
subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
complex(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_fix_coo_inner_rowmajor
end interface
interface
subroutine psb_c_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
interface
subroutine psb_c_fix_coo_inner_colmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
@@ -1884,7 +1876,18 @@ module psb_c_base_mat_mod
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_fix_coo_inner_colmajor
end interface
interface
subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
complex(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_fix_coo_inner_rowmajor
end interface
!
base/modules/serial/psb_c_base_vect_mod.F90
+6 -6
View File
@@ -1208,7 +1208,7 @@ contains
if (beta == cone) then
return
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i)
end do
@@ -1226,7 +1226,7 @@ contains
z%v(i) = z%v(i) + y(i)*x(i)
end do
else
!$omp parallel do private(i)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) + y(i)*x(i)
end do
@@ -1243,24 +1243,24 @@ contains
z%v(i) = z%v(i) - y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) - y(i)*x(i)
end do
end if
else
if (beta == czero) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = alpha*y(i)*x(i)
end do
else if (beta == cone) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = z%v(i) + alpha*y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(alpha, beta)
!$omp parallel do private(i) shared(alpha, beta)
do i=1, n
z%v(i) = beta*z%v(i) + alpha*y(i)*x(i)
end do
base/modules/serial/psb_c_mat_mod.F90
+24 -1
View File
@@ -84,7 +84,9 @@ module psb_c_mat_mod
type :: psb_cspmat_type
class(psb_c_base_sparse_mat), allocatable :: a
class(psb_c_base_sparse_mat), allocatable :: a
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_lc_coo_sparse_mat), allocatable :: rmta
contains
! Getters
@@ -109,6 +111,8 @@ module psb_c_mat_mod
procedure, pass(a) :: is_repeatable_updates => psb_c_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_c_get_fmt
procedure, pass(a) :: sizeof => psb_c_sizeof
procedure, pass(a) :: is_remote_build => psb_c_is_remote_build
! Setters
procedure, pass(a) :: set_nrows => psb_c_set_nrows
@@ -125,6 +129,7 @@ module psb_c_mat_mod
procedure, pass(a) :: set_symmetric => psb_c_set_symmetric
procedure, pass(a) :: set_unit => psb_c_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_c_set_repeatable_updates
procedure, pass(a) :: set_remote_build => psb_c_set_remote_build
! Memory/data management
procedure, pass(a) :: csall => psb_c_csall
@@ -2292,7 +2297,25 @@ contains
end function c_mat_is_sync
function psb_c_is_remote_build(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
logical :: res
res = (a%remote_build == psb_matbld_remote_)
end function psb_c_is_remote_build
subroutine psb_c_set_remote_build(a,val)
implicit none
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
a%remote_build = val
else
a%remote_build = psb_matbld_remote_
end if
end subroutine psb_c_set_remote_build
function psb_c_is_repeatable_updates(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
base/modules/serial/psb_c_vect_mod.F90
+139 -24
View File
@@ -39,15 +39,27 @@
!
module psb_c_vect_mod
use psb_realloc_mod
use psb_c_base_vect_mod
use psb_i_vect_mod
type psb_c_vect_type
class(psb_c_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
complex(psb_spk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
procedure, pass(x) :: get_nrows => c_vect_get_nrows
procedure, pass(x) :: sizeof => c_vect_sizeof
procedure, pass(x) :: get_fmt => c_vect_get_fmt
procedure, pass(x) :: is_remote_build => c_vect_is_remote_build
procedure, pass(x) :: set_remote_build => c_vect_set_remote_build
procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_nrmv => c_vect_get_nrmv
procedure, pass(x) :: set_nrmv => c_vect_set_nrmv
procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero
@@ -145,7 +157,9 @@ module psb_c_vect_mod
& c_vect_cnv, c_vect_set_scal, &
& c_vect_set_vect, c_vect_clone, c_vect_sync, c_vect_is_host, &
& c_vect_is_dev, c_vect_is_sync, c_vect_set_host, &
& c_vect_set_dev, c_vect_set_sync
& c_vect_set_dev, c_vect_set_sync, &
& c_vect_set_remote_build, c_is_remote_build, &
& c_vect_set_dupl, c_get_dupl, c_vect_set_nrmv, c_get_nrmv
private :: c_vect_dot_v, c_vect_dot_a, c_vect_axpby_v, c_vect_axpby_a, &
& c_vect_mlt_v, c_vect_mlt_a, c_vect_mlt_a_2, c_vect_mlt_v_2, &
@@ -167,7 +181,60 @@ module psb_c_vect_mod
contains
function c_vect_get_dupl(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function c_vect_get_dupl
subroutine c_vect_set_dupl(x,val)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine c_vect_set_dupl
function c_vect_get_nrmv(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function c_vect_get_nrmv
subroutine c_vect_set_nrmv(x,val)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine c_vect_set_nrmv
function c_vect_is_remote_build(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function c_vect_is_remote_build
subroutine c_vect_set_remote_build(x,val)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine c_vect_set_remote_build
subroutine psb_c_set_vect_default(v)
implicit none
class(psb_c_base_vect_type), intent(in) :: v
@@ -365,8 +432,8 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold
if (allocated(x%v)) &
& call x%free(info)
@@ -381,7 +448,6 @@ contains
else
info = psb_err_alloc_dealloc_
end if
end subroutine c_vect_all
subroutine c_vect_reall(n, x, info)
@@ -412,13 +478,13 @@ contains
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%v%asb(n,info)
end if
end subroutine c_vect_asb
subroutine c_vect_gthab(n,idx,alpha,x,beta,y)
@@ -469,44 +535,44 @@ contains
end subroutine c_vect_free
subroutine c_vect_ins_a(n,irl,val,dupl,x,info)
subroutine c_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine c_vect_ins_a
subroutine c_vect_ins_v(n,irl,val,dupl,x,info)
subroutine c_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl
class(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine c_vect_ins_v
@@ -526,9 +592,11 @@ contains
allocate(tmp,stat=info,mold=psb_c_get_base_vect_default())
end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
endif
end if
call move_alloc(tmp,x%v)
@@ -1182,7 +1250,6 @@ contains
end module psb_c_vect_mod
module psb_c_multivect_mod
use psb_c_base_multivect_mod
@@ -1194,11 +1261,19 @@ module psb_c_multivect_mod
type psb_c_multivect_type
class(psb_c_base_multivect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
complex(psb_spk_), allocatable :: rmtv(:,:)
contains
procedure, pass(x) :: get_nrows => c_vect_get_nrows
procedure, pass(x) :: get_ncols => c_vect_get_ncols
procedure, pass(x) :: sizeof => c_vect_sizeof
procedure, pass(x) :: get_fmt => c_vect_get_fmt
procedure, pass(x) :: is_remote_build => c_mvect_is_remote_build
procedure, pass(x) :: set_remote_build => c_mvect_set_remote_build
procedure, pass(x) :: get_dupl => c_mvect_get_dupl
procedure, pass(x) :: set_dupl => c_mvect_set_dupl
procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall
@@ -1266,6 +1341,46 @@ module psb_c_multivect_mod
contains
function c_mvect_get_dupl(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function c_mvect_get_dupl
subroutine c_mvect_set_dupl(x,val)
implicit none
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine c_mvect_set_dupl
function c_mvect_is_remote_build(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function c_mvect_is_remote_build
subroutine c_mvect_set_remote_build(x,val)
implicit none
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine c_mvect_set_remote_build
subroutine psb_c_set_multivect_default(v)
implicit none
@@ -1570,23 +1685,23 @@ contains
end subroutine c_vect_free
subroutine c_vect_ins(n,irl,val,dupl,x,info)
subroutine c_vect_ins(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine c_vect_ins
base/modules/serial/psb_d_base_mat_mod.F90
+16 -13
View File
@@ -1865,18 +1865,10 @@ module psb_d_base_mat_mod
integer(psb_ipk_), intent(in), optional :: idir
end subroutine psb_d_fix_coo_inner
end interface
interface
subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
real(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_fix_coo_inner_rowmajor
end interface
interface
subroutine psb_d_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
interface
subroutine psb_d_fix_coo_inner_colmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
@@ -1884,7 +1876,18 @@ module psb_d_base_mat_mod
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_fix_coo_inner_colmajor
end interface
interface
subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
real(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_fix_coo_inner_rowmajor
end interface
!
base/modules/serial/psb_d_base_vect_mod.F90
+6 -6
View File
@@ -1215,7 +1215,7 @@ contains
if (beta == done) then
return
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i)
end do
@@ -1233,7 +1233,7 @@ contains
z%v(i) = z%v(i) + y(i)*x(i)
end do
else
!$omp parallel do private(i)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) + y(i)*x(i)
end do
@@ -1250,24 +1250,24 @@ contains
z%v(i) = z%v(i) - y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) - y(i)*x(i)
end do
end if
else
if (beta == dzero) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = alpha*y(i)*x(i)
end do
else if (beta == done) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = z%v(i) + alpha*y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(alpha, beta)
!$omp parallel do private(i) shared(alpha, beta)
do i=1, n
z%v(i) = beta*z%v(i) + alpha*y(i)*x(i)
end do
base/modules/serial/psb_d_mat_mod.F90
+24 -1
View File
@@ -84,7 +84,9 @@ module psb_d_mat_mod
type :: psb_dspmat_type
class(psb_d_base_sparse_mat), allocatable :: a
class(psb_d_base_sparse_mat), allocatable :: a
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_ld_coo_sparse_mat), allocatable :: rmta
contains
! Getters
@@ -109,6 +111,8 @@ module psb_d_mat_mod
procedure, pass(a) :: is_repeatable_updates => psb_d_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_d_get_fmt
procedure, pass(a) :: sizeof => psb_d_sizeof
procedure, pass(a) :: is_remote_build => psb_d_is_remote_build
! Setters
procedure, pass(a) :: set_nrows => psb_d_set_nrows
@@ -125,6 +129,7 @@ module psb_d_mat_mod
procedure, pass(a) :: set_symmetric => psb_d_set_symmetric
procedure, pass(a) :: set_unit => psb_d_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_d_set_repeatable_updates
procedure, pass(a) :: set_remote_build => psb_d_set_remote_build
! Memory/data management
procedure, pass(a) :: csall => psb_d_csall
@@ -2292,7 +2297,25 @@ contains
end function d_mat_is_sync
function psb_d_is_remote_build(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
logical :: res
res = (a%remote_build == psb_matbld_remote_)
end function psb_d_is_remote_build
subroutine psb_d_set_remote_build(a,val)
implicit none
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
a%remote_build = val
else
a%remote_build = psb_matbld_remote_
end if
end subroutine psb_d_set_remote_build
function psb_d_is_repeatable_updates(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
base/modules/serial/psb_d_vect_mod.F90
+139 -24
View File
@@ -39,15 +39,27 @@
!
module psb_d_vect_mod
use psb_realloc_mod
use psb_d_base_vect_mod
use psb_i_vect_mod
type psb_d_vect_type
class(psb_d_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_dpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
procedure, pass(x) :: get_nrows => d_vect_get_nrows
procedure, pass(x) :: sizeof => d_vect_sizeof
procedure, pass(x) :: get_fmt => d_vect_get_fmt
procedure, pass(x) :: is_remote_build => d_vect_is_remote_build
procedure, pass(x) :: set_remote_build => d_vect_set_remote_build
procedure, pass(x) :: get_dupl => d_vect_get_dupl
procedure, pass(x) :: set_dupl => d_vect_set_dupl
procedure, pass(x) :: get_nrmv => d_vect_get_nrmv
procedure, pass(x) :: set_nrmv => d_vect_set_nrmv
procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero
@@ -152,7 +164,9 @@ module psb_d_vect_mod
& d_vect_cnv, d_vect_set_scal, &
& d_vect_set_vect, d_vect_clone, d_vect_sync, d_vect_is_host, &
& d_vect_is_dev, d_vect_is_sync, d_vect_set_host, &
& d_vect_set_dev, d_vect_set_sync
& d_vect_set_dev, d_vect_set_sync, &
& d_vect_set_remote_build, d_is_remote_build, &
& d_vect_set_dupl, d_get_dupl, d_vect_set_nrmv, d_get_nrmv
private :: d_vect_dot_v, d_vect_dot_a, d_vect_axpby_v, d_vect_axpby_a, &
& d_vect_mlt_v, d_vect_mlt_a, d_vect_mlt_a_2, d_vect_mlt_v_2, &
@@ -174,7 +188,60 @@ module psb_d_vect_mod
contains
function d_vect_get_dupl(x) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function d_vect_get_dupl
subroutine d_vect_set_dupl(x,val)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine d_vect_set_dupl
function d_vect_get_nrmv(x) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function d_vect_get_nrmv
subroutine d_vect_set_nrmv(x,val)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine d_vect_set_nrmv
function d_vect_is_remote_build(x) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function d_vect_is_remote_build
subroutine d_vect_set_remote_build(x,val)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine d_vect_set_remote_build
subroutine psb_d_set_vect_default(v)
implicit none
class(psb_d_base_vect_type), intent(in) :: v
@@ -372,8 +439,8 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
if (allocated(x%v)) &
& call x%free(info)
@@ -388,7 +455,6 @@ contains
else
info = psb_err_alloc_dealloc_
end if
end subroutine d_vect_all
subroutine d_vect_reall(n, x, info)
@@ -419,13 +485,13 @@ contains
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%v%asb(n,info)
end if
end subroutine d_vect_asb
subroutine d_vect_gthab(n,idx,alpha,x,beta,y)
@@ -476,44 +542,44 @@ contains
end subroutine d_vect_free
subroutine d_vect_ins_a(n,irl,val,dupl,x,info)
subroutine d_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine d_vect_ins_a
subroutine d_vect_ins_v(n,irl,val,dupl,x,info)
subroutine d_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine d_vect_ins_v
@@ -533,9 +599,11 @@ contains
allocate(tmp,stat=info,mold=psb_d_get_base_vect_default())
end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
endif
end if
call move_alloc(tmp,x%v)
@@ -1261,7 +1329,6 @@ contains
end module psb_d_vect_mod
module psb_d_multivect_mod
use psb_d_base_multivect_mod
@@ -1273,11 +1340,19 @@ module psb_d_multivect_mod
type psb_d_multivect_type
class(psb_d_base_multivect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_dpk_), allocatable :: rmtv(:,:)
contains
procedure, pass(x) :: get_nrows => d_vect_get_nrows
procedure, pass(x) :: get_ncols => d_vect_get_ncols
procedure, pass(x) :: sizeof => d_vect_sizeof
procedure, pass(x) :: get_fmt => d_vect_get_fmt
procedure, pass(x) :: is_remote_build => d_mvect_is_remote_build
procedure, pass(x) :: set_remote_build => d_mvect_set_remote_build
procedure, pass(x) :: get_dupl => d_mvect_get_dupl
procedure, pass(x) :: set_dupl => d_mvect_set_dupl
procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall
@@ -1345,6 +1420,46 @@ module psb_d_multivect_mod
contains
function d_mvect_get_dupl(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function d_mvect_get_dupl
subroutine d_mvect_set_dupl(x,val)
implicit none
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine d_mvect_set_dupl
function d_mvect_is_remote_build(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function d_mvect_is_remote_build
subroutine d_mvect_set_remote_build(x,val)
implicit none
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine d_mvect_set_remote_build
subroutine psb_d_set_multivect_default(v)
implicit none
@@ -1649,23 +1764,23 @@ contains
end subroutine d_vect_free
subroutine d_vect_ins(n,irl,val,dupl,x,info)
subroutine d_vect_ins(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine d_vect_ins
base/modules/serial/psb_i_vect_mod.F90
+139 -24
View File
@@ -39,14 +39,26 @@
!
module psb_i_vect_mod
use psb_realloc_mod
use psb_i_base_vect_mod
type psb_i_vect_type
class(psb_i_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
integer(psb_ipk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
procedure, pass(x) :: get_nrows => i_vect_get_nrows
procedure, pass(x) :: sizeof => i_vect_sizeof
procedure, pass(x) :: get_fmt => i_vect_get_fmt
procedure, pass(x) :: is_remote_build => i_vect_is_remote_build
procedure, pass(x) :: set_remote_build => i_vect_set_remote_build
procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_nrmv => i_vect_get_nrmv
procedure, pass(x) :: set_nrmv => i_vect_set_nrmv
procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero
@@ -97,7 +109,9 @@ module psb_i_vect_mod
& i_vect_cnv, i_vect_set_scal, &
& i_vect_set_vect, i_vect_clone, i_vect_sync, i_vect_is_host, &
& i_vect_is_dev, i_vect_is_sync, i_vect_set_host, &
& i_vect_set_dev, i_vect_set_sync
& i_vect_set_dev, i_vect_set_sync, &
& i_vect_set_remote_build, i_is_remote_build, &
& i_vect_set_dupl, i_get_dupl, i_vect_set_nrmv, i_get_nrmv
class(psb_i_base_vect_type), allocatable, target,&
@@ -114,7 +128,60 @@ module psb_i_vect_mod
contains
function i_vect_get_dupl(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function i_vect_get_dupl
subroutine i_vect_set_dupl(x,val)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine i_vect_set_dupl
function i_vect_get_nrmv(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function i_vect_get_nrmv
subroutine i_vect_set_nrmv(x,val)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine i_vect_set_nrmv
function i_vect_is_remote_build(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function i_vect_is_remote_build
subroutine i_vect_set_remote_build(x,val)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine i_vect_set_remote_build
subroutine psb_i_set_vect_default(v)
implicit none
class(psb_i_base_vect_type), intent(in) :: v
@@ -312,8 +379,8 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold
if (allocated(x%v)) &
& call x%free(info)
@@ -328,7 +395,6 @@ contains
else
info = psb_err_alloc_dealloc_
end if
end subroutine i_vect_all
subroutine i_vect_reall(n, x, info)
@@ -359,13 +425,13 @@ contains
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%v%asb(n,info)
end if
end subroutine i_vect_asb
subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
@@ -416,44 +482,44 @@ contains
end subroutine i_vect_free
subroutine i_vect_ins_a(n,irl,val,dupl,x,info)
subroutine i_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins_a
subroutine i_vect_ins_v(n,irl,val,dupl,x,info)
subroutine i_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl
class(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine i_vect_ins_v
@@ -473,9 +539,11 @@ contains
allocate(tmp,stat=info,mold=psb_i_get_base_vect_default())
end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
endif
end if
call move_alloc(tmp,x%v)
@@ -557,7 +625,6 @@ contains
end module psb_i_vect_mod
module psb_i_multivect_mod
use psb_i_base_multivect_mod
@@ -569,11 +636,19 @@ module psb_i_multivect_mod
type psb_i_multivect_type
class(psb_i_base_multivect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
integer(psb_ipk_), allocatable :: rmtv(:,:)
contains
procedure, pass(x) :: get_nrows => i_vect_get_nrows
procedure, pass(x) :: get_ncols => i_vect_get_ncols
procedure, pass(x) :: sizeof => i_vect_sizeof
procedure, pass(x) :: get_fmt => i_vect_get_fmt
procedure, pass(x) :: is_remote_build => i_mvect_is_remote_build
procedure, pass(x) :: set_remote_build => i_mvect_set_remote_build
procedure, pass(x) :: get_dupl => i_mvect_get_dupl
procedure, pass(x) :: set_dupl => i_mvect_set_dupl
procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall
@@ -623,6 +698,46 @@ module psb_i_multivect_mod
contains
function i_mvect_get_dupl(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function i_mvect_get_dupl
subroutine i_mvect_set_dupl(x,val)
implicit none
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine i_mvect_set_dupl
function i_mvect_is_remote_build(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function i_mvect_is_remote_build
subroutine i_mvect_set_remote_build(x,val)
implicit none
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine i_mvect_set_remote_build
subroutine psb_i_set_multivect_default(v)
implicit none
@@ -927,23 +1042,23 @@ contains
end subroutine i_vect_free
subroutine i_vect_ins(n,irl,val,dupl,x,info)
subroutine i_vect_ins(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins
base/modules/serial/psb_l_vect_mod.F90
+139 -24
View File
@@ -39,15 +39,27 @@
!
module psb_l_vect_mod
use psb_realloc_mod
use psb_l_base_vect_mod
use psb_i_vect_mod
type psb_l_vect_type
class(psb_l_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
integer(psb_lpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
procedure, pass(x) :: get_nrows => l_vect_get_nrows
procedure, pass(x) :: sizeof => l_vect_sizeof
procedure, pass(x) :: get_fmt => l_vect_get_fmt
procedure, pass(x) :: is_remote_build => l_vect_is_remote_build
procedure, pass(x) :: set_remote_build => l_vect_set_remote_build
procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_nrmv => l_vect_get_nrmv
procedure, pass(x) :: set_nrmv => l_vect_set_nrmv
procedure, pass(x) :: all => l_vect_all
procedure, pass(x) :: reall => l_vect_reall
procedure, pass(x) :: zero => l_vect_zero
@@ -98,7 +110,9 @@ module psb_l_vect_mod
& l_vect_cnv, l_vect_set_scal, &
& l_vect_set_vect, l_vect_clone, l_vect_sync, l_vect_is_host, &
& l_vect_is_dev, l_vect_is_sync, l_vect_set_host, &
& l_vect_set_dev, l_vect_set_sync
& l_vect_set_dev, l_vect_set_sync, &
& l_vect_set_remote_build, l_is_remote_build, &
& l_vect_set_dupl, l_get_dupl, l_vect_set_nrmv, l_get_nrmv
class(psb_l_base_vect_type), allocatable, target,&
@@ -115,7 +129,60 @@ module psb_l_vect_mod
contains
function l_vect_get_dupl(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function l_vect_get_dupl
subroutine l_vect_set_dupl(x,val)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine l_vect_set_dupl
function l_vect_get_nrmv(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function l_vect_get_nrmv
subroutine l_vect_set_nrmv(x,val)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine l_vect_set_nrmv
function l_vect_is_remote_build(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function l_vect_is_remote_build
subroutine l_vect_set_remote_build(x,val)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine l_vect_set_remote_build
subroutine psb_l_set_vect_default(v)
implicit none
class(psb_l_base_vect_type), intent(in) :: v
@@ -313,8 +380,8 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold
if (allocated(x%v)) &
& call x%free(info)
@@ -329,7 +396,6 @@ contains
else
info = psb_err_alloc_dealloc_
end if
end subroutine l_vect_all
subroutine l_vect_reall(n, x, info)
@@ -360,13 +426,13 @@ contains
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%v%asb(n,info)
end if
end subroutine l_vect_asb
subroutine l_vect_gthab(n,idx,alpha,x,beta,y)
@@ -417,44 +483,44 @@ contains
end subroutine l_vect_free
subroutine l_vect_ins_a(n,irl,val,dupl,x,info)
subroutine l_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine l_vect_ins_a
subroutine l_vect_ins_v(n,irl,val,dupl,x,info)
subroutine l_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl
class(psb_l_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine l_vect_ins_v
@@ -474,9 +540,11 @@ contains
allocate(tmp,stat=info,mold=psb_l_get_base_vect_default())
end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
endif
end if
call move_alloc(tmp,x%v)
@@ -558,7 +626,6 @@ contains
end module psb_l_vect_mod
module psb_l_multivect_mod
use psb_l_base_multivect_mod
@@ -570,11 +637,19 @@ module psb_l_multivect_mod
type psb_l_multivect_type
class(psb_l_base_multivect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
integer(psb_lpk_), allocatable :: rmtv(:,:)
contains
procedure, pass(x) :: get_nrows => l_vect_get_nrows
procedure, pass(x) :: get_ncols => l_vect_get_ncols
procedure, pass(x) :: sizeof => l_vect_sizeof
procedure, pass(x) :: get_fmt => l_vect_get_fmt
procedure, pass(x) :: is_remote_build => l_mvect_is_remote_build
procedure, pass(x) :: set_remote_build => l_mvect_set_remote_build
procedure, pass(x) :: get_dupl => l_mvect_get_dupl
procedure, pass(x) :: set_dupl => l_mvect_set_dupl
procedure, pass(x) :: all => l_vect_all
procedure, pass(x) :: reall => l_vect_reall
@@ -624,6 +699,46 @@ module psb_l_multivect_mod
contains
function l_mvect_get_dupl(x) result(res)
implicit none
class(psb_l_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function l_mvect_get_dupl
subroutine l_mvect_set_dupl(x,val)
implicit none
class(psb_l_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine l_mvect_set_dupl
function l_mvect_is_remote_build(x) result(res)
implicit none
class(psb_l_multivect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function l_mvect_is_remote_build
subroutine l_mvect_set_remote_build(x,val)
implicit none
class(psb_l_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine l_mvect_set_remote_build
subroutine psb_l_set_multivect_default(v)
implicit none
@@ -928,23 +1043,23 @@ contains
end subroutine l_vect_free
subroutine l_vect_ins(n,irl,val,dupl,x,info)
subroutine l_vect_ins(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_l_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine l_vect_ins
base/modules/serial/psb_s_base_mat_mod.F90
+16 -13
View File
@@ -1865,18 +1865,10 @@ module psb_s_base_mat_mod
integer(psb_ipk_), intent(in), optional :: idir
end subroutine psb_s_fix_coo_inner
end interface
interface
subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
real(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_fix_coo_inner_rowmajor
end interface
interface
subroutine psb_s_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
interface
subroutine psb_s_fix_coo_inner_colmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
@@ -1884,7 +1876,18 @@ module psb_s_base_mat_mod
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_fix_coo_inner_colmajor
end interface
interface
subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
real(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_fix_coo_inner_rowmajor
end interface
!
base/modules/serial/psb_s_base_vect_mod.F90
+6 -6
View File
@@ -1215,7 +1215,7 @@ contains
if (beta == sone) then
return
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i)
end do
@@ -1233,7 +1233,7 @@ contains
z%v(i) = z%v(i) + y(i)*x(i)
end do
else
!$omp parallel do private(i)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) + y(i)*x(i)
end do
@@ -1250,24 +1250,24 @@ contains
z%v(i) = z%v(i) - y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) - y(i)*x(i)
end do
end if
else
if (beta == szero) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = alpha*y(i)*x(i)
end do
else if (beta == sone) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = z%v(i) + alpha*y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(alpha, beta)
!$omp parallel do private(i) shared(alpha, beta)
do i=1, n
z%v(i) = beta*z%v(i) + alpha*y(i)*x(i)
end do
base/modules/serial/psb_s_mat_mod.F90
+24 -1
View File
@@ -84,7 +84,9 @@ module psb_s_mat_mod
type :: psb_sspmat_type
class(psb_s_base_sparse_mat), allocatable :: a
class(psb_s_base_sparse_mat), allocatable :: a
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_ls_coo_sparse_mat), allocatable :: rmta
contains
! Getters
@@ -109,6 +111,8 @@ module psb_s_mat_mod
procedure, pass(a) :: is_repeatable_updates => psb_s_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_s_get_fmt
procedure, pass(a) :: sizeof => psb_s_sizeof
procedure, pass(a) :: is_remote_build => psb_s_is_remote_build
! Setters
procedure, pass(a) :: set_nrows => psb_s_set_nrows
@@ -125,6 +129,7 @@ module psb_s_mat_mod
procedure, pass(a) :: set_symmetric => psb_s_set_symmetric
procedure, pass(a) :: set_unit => psb_s_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_s_set_repeatable_updates
procedure, pass(a) :: set_remote_build => psb_s_set_remote_build
! Memory/data management
procedure, pass(a) :: csall => psb_s_csall
@@ -2292,7 +2297,25 @@ contains
end function s_mat_is_sync
function psb_s_is_remote_build(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
logical :: res
res = (a%remote_build == psb_matbld_remote_)
end function psb_s_is_remote_build
subroutine psb_s_set_remote_build(a,val)
implicit none
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
a%remote_build = val
else
a%remote_build = psb_matbld_remote_
end if
end subroutine psb_s_set_remote_build
function psb_s_is_repeatable_updates(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
base/modules/serial/psb_s_vect_mod.F90
+139 -24
View File
@@ -39,15 +39,27 @@
!
module psb_s_vect_mod
use psb_realloc_mod
use psb_s_base_vect_mod
use psb_i_vect_mod
type psb_s_vect_type
class(psb_s_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_spk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
procedure, pass(x) :: get_nrows => s_vect_get_nrows
procedure, pass(x) :: sizeof => s_vect_sizeof
procedure, pass(x) :: get_fmt => s_vect_get_fmt
procedure, pass(x) :: is_remote_build => s_vect_is_remote_build
procedure, pass(x) :: set_remote_build => s_vect_set_remote_build
procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_nrmv => s_vect_get_nrmv
procedure, pass(x) :: set_nrmv => s_vect_set_nrmv
procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero
@@ -152,7 +164,9 @@ module psb_s_vect_mod
& s_vect_cnv, s_vect_set_scal, &
& s_vect_set_vect, s_vect_clone, s_vect_sync, s_vect_is_host, &
& s_vect_is_dev, s_vect_is_sync, s_vect_set_host, &
& s_vect_set_dev, s_vect_set_sync
& s_vect_set_dev, s_vect_set_sync, &
& s_vect_set_remote_build, s_is_remote_build, &
& s_vect_set_dupl, s_get_dupl, s_vect_set_nrmv, s_get_nrmv
private :: s_vect_dot_v, s_vect_dot_a, s_vect_axpby_v, s_vect_axpby_a, &
& s_vect_mlt_v, s_vect_mlt_a, s_vect_mlt_a_2, s_vect_mlt_v_2, &
@@ -174,7 +188,60 @@ module psb_s_vect_mod
contains
function s_vect_get_dupl(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function s_vect_get_dupl
subroutine s_vect_set_dupl(x,val)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine s_vect_set_dupl
function s_vect_get_nrmv(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function s_vect_get_nrmv
subroutine s_vect_set_nrmv(x,val)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine s_vect_set_nrmv
function s_vect_is_remote_build(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function s_vect_is_remote_build
subroutine s_vect_set_remote_build(x,val)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine s_vect_set_remote_build
subroutine psb_s_set_vect_default(v)
implicit none
class(psb_s_base_vect_type), intent(in) :: v
@@ -372,8 +439,8 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold
if (allocated(x%v)) &
& call x%free(info)
@@ -388,7 +455,6 @@ contains
else
info = psb_err_alloc_dealloc_
end if
end subroutine s_vect_all
subroutine s_vect_reall(n, x, info)
@@ -419,13 +485,13 @@ contains
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%v%asb(n,info)
end if
end subroutine s_vect_asb
subroutine s_vect_gthab(n,idx,alpha,x,beta,y)
@@ -476,44 +542,44 @@ contains
end subroutine s_vect_free
subroutine s_vect_ins_a(n,irl,val,dupl,x,info)
subroutine s_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine s_vect_ins_a
subroutine s_vect_ins_v(n,irl,val,dupl,x,info)
subroutine s_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl
class(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine s_vect_ins_v
@@ -533,9 +599,11 @@ contains
allocate(tmp,stat=info,mold=psb_s_get_base_vect_default())
end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
endif
end if
call move_alloc(tmp,x%v)
@@ -1261,7 +1329,6 @@ contains
end module psb_s_vect_mod
module psb_s_multivect_mod
use psb_s_base_multivect_mod
@@ -1273,11 +1340,19 @@ module psb_s_multivect_mod
type psb_s_multivect_type
class(psb_s_base_multivect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
real(psb_spk_), allocatable :: rmtv(:,:)
contains
procedure, pass(x) :: get_nrows => s_vect_get_nrows
procedure, pass(x) :: get_ncols => s_vect_get_ncols
procedure, pass(x) :: sizeof => s_vect_sizeof
procedure, pass(x) :: get_fmt => s_vect_get_fmt
procedure, pass(x) :: is_remote_build => s_mvect_is_remote_build
procedure, pass(x) :: set_remote_build => s_mvect_set_remote_build
procedure, pass(x) :: get_dupl => s_mvect_get_dupl
procedure, pass(x) :: set_dupl => s_mvect_set_dupl
procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall
@@ -1345,6 +1420,46 @@ module psb_s_multivect_mod
contains
function s_mvect_get_dupl(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function s_mvect_get_dupl
subroutine s_mvect_set_dupl(x,val)
implicit none
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine s_mvect_set_dupl
function s_mvect_is_remote_build(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function s_mvect_is_remote_build
subroutine s_mvect_set_remote_build(x,val)
implicit none
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine s_mvect_set_remote_build
subroutine psb_s_set_multivect_default(v)
implicit none
@@ -1649,23 +1764,23 @@ contains
end subroutine s_vect_free
subroutine s_vect_ins(n,irl,val,dupl,x,info)
subroutine s_vect_ins(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine s_vect_ins
base/modules/serial/psb_z_base_mat_mod.F90
+16 -13
View File
@@ -1865,18 +1865,10 @@ module psb_z_base_mat_mod
integer(psb_ipk_), intent(in), optional :: idir
end subroutine psb_z_fix_coo_inner
end interface
interface
subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
complex(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_fix_coo_inner_rowmajor
end interface
interface
subroutine psb_z_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,info)
interface
subroutine psb_z_fix_coo_inner_colmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
@@ -1884,7 +1876,18 @@ module psb_z_base_mat_mod
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_fix_coo_inner_colmajor
end interface
interface
subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,&
& ia,ja,val,iaux,nzout,info)
import
integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl
integer(psb_ipk_), intent(inout) :: ia(:), ja(:), iaux(:)
complex(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_fix_coo_inner_rowmajor
end interface
!
base/modules/serial/psb_z_base_vect_mod.F90
+6 -6
View File
@@ -1208,7 +1208,7 @@ contains
if (beta == zone) then
return
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i)
end do
@@ -1226,7 +1226,7 @@ contains
z%v(i) = z%v(i) + y(i)*x(i)
end do
else
!$omp parallel do private(i)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) + y(i)*x(i)
end do
@@ -1243,24 +1243,24 @@ contains
z%v(i) = z%v(i) - y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(beta)
!$omp parallel do private(i) shared(beta)
do i=1, n
z%v(i) = beta*z%v(i) - y(i)*x(i)
end do
end if
else
if (beta == zzero) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = alpha*y(i)*x(i)
end do
else if (beta == zone) then
!$omp parallel do private(i) shared(alpha)
!$omp parallel do private(i) shared(alpha)
do i=1, n
z%v(i) = z%v(i) + alpha*y(i)*x(i)
end do
else
!$omp parallel do private(i) shared(alpha, beta)
!$omp parallel do private(i) shared(alpha, beta)
do i=1, n
z%v(i) = beta*z%v(i) + alpha*y(i)*x(i)
end do
base/modules/serial/psb_z_mat_mod.F90
+24 -1
View File
@@ -84,7 +84,9 @@ module psb_z_mat_mod
type :: psb_zspmat_type
class(psb_z_base_sparse_mat), allocatable :: a
class(psb_z_base_sparse_mat), allocatable :: a
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
type(psb_lz_coo_sparse_mat), allocatable :: rmta
contains
! Getters
@@ -109,6 +111,8 @@ module psb_z_mat_mod
procedure, pass(a) :: is_repeatable_updates => psb_z_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_z_get_fmt
procedure, pass(a) :: sizeof => psb_z_sizeof
procedure, pass(a) :: is_remote_build => psb_z_is_remote_build
! Setters
procedure, pass(a) :: set_nrows => psb_z_set_nrows
@@ -125,6 +129,7 @@ module psb_z_mat_mod
procedure, pass(a) :: set_symmetric => psb_z_set_symmetric
procedure, pass(a) :: set_unit => psb_z_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_z_set_repeatable_updates
procedure, pass(a) :: set_remote_build => psb_z_set_remote_build
! Memory/data management
procedure, pass(a) :: csall => psb_z_csall
@@ -2292,7 +2297,25 @@ contains
end function z_mat_is_sync
function psb_z_is_remote_build(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
logical :: res
res = (a%remote_build == psb_matbld_remote_)
end function psb_z_is_remote_build
subroutine psb_z_set_remote_build(a,val)
implicit none
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
a%remote_build = val
else
a%remote_build = psb_matbld_remote_
end if
end subroutine psb_z_set_remote_build
function psb_z_is_repeatable_updates(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
base/modules/serial/psb_z_vect_mod.F90
+139 -24
View File
@@ -39,15 +39,27 @@
!
module psb_z_vect_mod
use psb_realloc_mod
use psb_z_base_vect_mod
use psb_i_vect_mod
type psb_z_vect_type
class(psb_z_base_vect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
complex(psb_dpk_), allocatable :: rmtv(:)
integer(psb_lpk_), allocatable :: rmidx(:)
contains
procedure, pass(x) :: get_nrows => z_vect_get_nrows
procedure, pass(x) :: sizeof => z_vect_sizeof
procedure, pass(x) :: get_fmt => z_vect_get_fmt
procedure, pass(x) :: is_remote_build => z_vect_is_remote_build
procedure, pass(x) :: set_remote_build => z_vect_set_remote_build
procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_nrmv => z_vect_get_nrmv
procedure, pass(x) :: set_nrmv => z_vect_set_nrmv
procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero
@@ -145,7 +157,9 @@ module psb_z_vect_mod
& z_vect_cnv, z_vect_set_scal, &
& z_vect_set_vect, z_vect_clone, z_vect_sync, z_vect_is_host, &
& z_vect_is_dev, z_vect_is_sync, z_vect_set_host, &
& z_vect_set_dev, z_vect_set_sync
& z_vect_set_dev, z_vect_set_sync, &
& z_vect_set_remote_build, z_is_remote_build, &
& z_vect_set_dupl, z_get_dupl, z_vect_set_nrmv, z_get_nrmv
private :: z_vect_dot_v, z_vect_dot_a, z_vect_axpby_v, z_vect_axpby_a, &
& z_vect_mlt_v, z_vect_mlt_a, z_vect_mlt_a_2, z_vect_mlt_v_2, &
@@ -167,7 +181,60 @@ module psb_z_vect_mod
contains
function z_vect_get_dupl(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function z_vect_get_dupl
subroutine z_vect_set_dupl(x,val)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine z_vect_set_dupl
function z_vect_get_nrmv(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function z_vect_get_nrmv
subroutine z_vect_set_nrmv(x,val)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine z_vect_set_nrmv
function z_vect_is_remote_build(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function z_vect_is_remote_build
subroutine z_vect_set_remote_build(x,val)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine z_vect_set_remote_build
subroutine psb_z_set_vect_default(v)
implicit none
class(psb_z_base_vect_type), intent(in) :: v
@@ -365,8 +432,8 @@ contains
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold
if (allocated(x%v)) &
& call x%free(info)
@@ -381,7 +448,6 @@ contains
else
info = psb_err_alloc_dealloc_
end if
end subroutine z_vect_all
subroutine z_vect_reall(n, x, info)
@@ -412,13 +478,13 @@ contains
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: n
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) then
call x%v%asb(n,info)
end if
end subroutine z_vect_asb
subroutine z_vect_gthab(n,idx,alpha,x,beta,y)
@@ -469,44 +535,44 @@ contains
end subroutine z_vect_free
subroutine z_vect_ins_a(n,irl,val,dupl,x,info)
subroutine z_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine z_vect_ins_a
subroutine z_vect_ins_v(n,irl,val,dupl,x,info)
subroutine z_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl
class(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine z_vect_ins_v
@@ -526,9 +592,11 @@ contains
allocate(tmp,stat=info,mold=psb_z_get_base_vect_default())
end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
if (allocated(x%v%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
endif
end if
call move_alloc(tmp,x%v)
@@ -1182,7 +1250,6 @@ contains
end module psb_z_vect_mod
module psb_z_multivect_mod
use psb_z_base_multivect_mod
@@ -1194,11 +1261,19 @@ module psb_z_multivect_mod
type psb_z_multivect_type
class(psb_z_base_multivect_type), allocatable :: v
integer(psb_ipk_) :: nrmv = 0
integer(psb_ipk_) :: remote_build=psb_matbld_noremote_
integer(psb_ipk_) :: dupl = psb_dupl_add_
complex(psb_dpk_), allocatable :: rmtv(:,:)
contains
procedure, pass(x) :: get_nrows => z_vect_get_nrows
procedure, pass(x) :: get_ncols => z_vect_get_ncols
procedure, pass(x) :: sizeof => z_vect_sizeof
procedure, pass(x) :: get_fmt => z_vect_get_fmt
procedure, pass(x) :: is_remote_build => z_mvect_is_remote_build
procedure, pass(x) :: set_remote_build => z_mvect_set_remote_build
procedure, pass(x) :: get_dupl => z_mvect_get_dupl
procedure, pass(x) :: set_dupl => z_mvect_set_dupl
procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall
@@ -1266,6 +1341,46 @@ module psb_z_multivect_mod
contains
function z_mvect_get_dupl(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%dupl
end function z_mvect_get_dupl
subroutine z_mvect_set_dupl(x,val)
implicit none
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%dupl = val
else
x%dupl = psb_dupl_def_
end if
end subroutine z_mvect_set_dupl
function z_mvect_is_remote_build(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
logical :: res
res = (x%remote_build == psb_matbld_remote_)
end function z_mvect_is_remote_build
subroutine z_mvect_set_remote_build(x,val)
implicit none
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in), optional :: val
if (present(val)) then
x%remote_build = val
else
x%remote_build = psb_matbld_remote_
end if
end subroutine z_mvect_set_remote_build
subroutine psb_z_set_multivect_default(v)
implicit none
@@ -1570,23 +1685,23 @@ contains
end subroutine z_vect_free
subroutine z_vect_ins(n,irl,val,dupl,x,info)
subroutine z_vect_ins(n,irl,val,x,info)
use psi_serial_mod
implicit none
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
integer(psb_ipk_) :: i, dupl
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info)
end subroutine z_vect_ins
base/modules/tools/psb_c_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_c_tools_a_mod
end subroutine psb_cinsvi
end interface
interface psb_remote_vect
subroutine psb_c_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
complex(psb_spk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
complex(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_remote_vect
end interface psb_remote_vect
end module psb_c_tools_a_mod
base/modules/tools/psb_c_tools_mod.F90
+31 -20
View File
@@ -40,28 +40,31 @@ Module psb_c_tools_mod
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_calloc_vect(x, desc_a,info)
subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
import
implicit none
type(psb_c_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_calloc_vect
subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
import
implicit none
type(psb_c_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_calloc_vect_r2
subroutine psb_calloc_multivect(x, desc_a,info,n)
subroutine psb_calloc_multivect(x, desc_a,info,n, dupl, bldmode)
import
implicit none
type(psb_c_multivect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_calloc_multivect
end interface
@@ -123,7 +126,7 @@ Module psb_c_tools_mod
interface psb_geins
subroutine psb_cins_vect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_cins_vect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -132,10 +135,9 @@ Module psb_c_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_cins_vect
subroutine psb_cins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_cins_vect_v(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -144,10 +146,9 @@ Module psb_c_tools_mod
type(psb_l_vect_type), intent(inout) :: irw
type(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_cins_vect_v
subroutine psb_cins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_cins_vect_r2(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -156,10 +157,9 @@ Module psb_c_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
complex(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_cins_vect_r2
subroutine psb_cins_multivect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_cins_multivect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -168,11 +168,10 @@ Module psb_c_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
complex(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_cins_multivect
end interface
interface psb_cdbldext
Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info,extype)
import
@@ -239,29 +238,41 @@ Module psb_c_tools_mod
interface psb_spall
subroutine psb_cspalloc(a, desc_a, info, nnz)
subroutine psb_cspalloc(a, desc_a, info, nnz, dupl, bldmode)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz, bldmode
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_cspalloc
end interface
interface psb_spasb
subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
import
implicit none
type(psb_cspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl, upd
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_c_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_cspasb
end interface
interface psb_remote_mat
subroutine psb_lc_remote_mat(a,desc_a,b, info)
import
implicit none
type(psb_lc_coo_sparse_mat),Intent(inout) :: a
type(psb_desc_type),intent(inout) :: desc_a
type(psb_lc_coo_sparse_mat),Intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lc_remote_mat
end interface psb_remote_mat
interface psb_spfree
subroutine psb_cspfree(a, desc_a,info)
import
base/modules/tools/psb_d_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_d_tools_a_mod
end subroutine psb_dinsvi
end interface
interface psb_remote_vect
subroutine psb_d_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
real(psb_dpk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_remote_vect
end interface psb_remote_vect
end module psb_d_tools_a_mod
base/modules/tools/psb_d_tools_mod.F90
+31 -20
View File
@@ -40,28 +40,31 @@ Module psb_d_tools_mod
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_dalloc_vect(x, desc_a,info)
subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
import
implicit none
type(psb_d_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_dalloc_vect
subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
import
implicit none
type(psb_d_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_dalloc_vect_r2
subroutine psb_dalloc_multivect(x, desc_a,info,n)
subroutine psb_dalloc_multivect(x, desc_a,info,n, dupl, bldmode)
import
implicit none
type(psb_d_multivect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_dalloc_multivect
end interface
@@ -123,7 +126,7 @@ Module psb_d_tools_mod
interface psb_geins
subroutine psb_dins_vect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_dins_vect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -132,10 +135,9 @@ Module psb_d_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_dins_vect
subroutine psb_dins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_dins_vect_v(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -144,10 +146,9 @@ Module psb_d_tools_mod
type(psb_l_vect_type), intent(inout) :: irw
type(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_dins_vect_v
subroutine psb_dins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_dins_vect_r2(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -156,10 +157,9 @@ Module psb_d_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_dins_vect_r2
subroutine psb_dins_multivect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_dins_multivect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -168,11 +168,10 @@ Module psb_d_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_dins_multivect
end interface
interface psb_cdbldext
Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info,extype)
import
@@ -239,29 +238,41 @@ Module psb_d_tools_mod
interface psb_spall
subroutine psb_dspalloc(a, desc_a, info, nnz)
subroutine psb_dspalloc(a, desc_a, info, nnz, dupl, bldmode)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz, bldmode
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_dspalloc
end interface
interface psb_spasb
subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl,mold)
subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
import
implicit none
type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl, upd
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_d_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_dspasb
end interface
interface psb_remote_mat
subroutine psb_ld_remote_mat(a,desc_a,b, info)
import
implicit none
type(psb_ld_coo_sparse_mat),Intent(inout) :: a
type(psb_desc_type),intent(inout) :: desc_a
type(psb_ld_coo_sparse_mat),Intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ld_remote_mat
end interface psb_remote_mat
interface psb_spfree
subroutine psb_dspfree(a, desc_a,info)
import
base/modules/tools/psb_e_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_e_tools_a_mod
end subroutine psb_einsvi
end interface
interface psb_remote_vect
subroutine psb_e_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_epk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
integer(psb_epk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_e_remote_vect
end interface psb_remote_vect
end module psb_e_tools_a_mod
base/modules/tools/psb_i2_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_i2_tools_a_mod
end subroutine psb_i2insvi
end interface
interface psb_remote_vect
subroutine psb_i2_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_i2pk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
integer(psb_i2pk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i2_remote_vect
end interface psb_remote_vect
end module psb_i2_tools_a_mod
base/modules/tools/psb_i_tools_mod.F90
+13 -12
View File
@@ -32,33 +32,38 @@
Module psb_i_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_
use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type
use psb_m_tools_a_mod
use psb_e_tools_a_mod
use psb_l_vect_mod, only : psb_l_vect_type
use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_ialloc_vect(x, desc_a,info)
subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
import
implicit none
type(psb_i_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_ialloc_vect
subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
import
implicit none
type(psb_i_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_ialloc_vect_r2
subroutine psb_ialloc_multivect(x, desc_a,info,n)
subroutine psb_ialloc_multivect(x, desc_a,info,n, dupl, bldmode)
import
implicit none
type(psb_i_multivect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_ialloc_multivect
end interface
@@ -120,7 +125,7 @@ Module psb_i_tools_mod
interface psb_geins
subroutine psb_iins_vect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_iins_vect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -129,10 +134,9 @@ Module psb_i_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect
subroutine psb_iins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_iins_vect_v(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -141,10 +145,9 @@ Module psb_i_tools_mod
type(psb_l_vect_type), intent(inout) :: irw
type(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect_v
subroutine psb_iins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_iins_vect_r2(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -153,10 +156,9 @@ Module psb_i_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_vect_r2
subroutine psb_iins_multivect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_iins_multivect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -165,9 +167,8 @@ Module psb_i_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_iins_multivect
end interface
end module psb_i_tools_mod
base/modules/tools/psb_l_tools_mod.F90
+13 -12
View File
@@ -32,33 +32,38 @@
Module psb_l_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_
use psb_l_vect_mod, only : psb_l_base_vect_type, psb_l_vect_type
use psb_m_tools_a_mod
use psb_e_tools_a_mod
! use psb_i_vect_mod, only : psb_i_vect_type
use psb_l_multivect_mod, only : psb_l_base_multivect_type, psb_l_multivect_type
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_lalloc_vect(x, desc_a,info)
subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
import
implicit none
type(psb_l_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_lalloc_vect
subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
import
implicit none
type(psb_l_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_lalloc_vect_r2
subroutine psb_lalloc_multivect(x, desc_a,info,n)
subroutine psb_lalloc_multivect(x, desc_a,info,n, dupl, bldmode)
import
implicit none
type(psb_l_multivect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_lalloc_multivect
end interface
@@ -120,7 +125,7 @@ Module psb_l_tools_mod
interface psb_geins
subroutine psb_lins_vect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_lins_vect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -129,10 +134,9 @@ Module psb_l_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_lins_vect
subroutine psb_lins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_lins_vect_v(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -141,10 +145,9 @@ Module psb_l_tools_mod
type(psb_l_vect_type), intent(inout) :: irw
type(psb_l_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_lins_vect_v
subroutine psb_lins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_lins_vect_r2(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -153,10 +156,9 @@ Module psb_l_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_lins_vect_r2
subroutine psb_lins_multivect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_lins_multivect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -165,9 +167,8 @@ Module psb_l_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_lins_multivect
end interface
end module psb_l_tools_mod
base/modules/tools/psb_m_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_m_tools_a_mod
end subroutine psb_minsvi
end interface
interface psb_remote_vect
subroutine psb_m_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_mpk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
integer(psb_mpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_m_remote_vect
end interface psb_remote_vect
end module psb_m_tools_a_mod
base/modules/tools/psb_s_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_s_tools_a_mod
end subroutine psb_sinsvi
end interface
interface psb_remote_vect
subroutine psb_s_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
real(psb_spk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
real(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_remote_vect
end interface psb_remote_vect
end module psb_s_tools_a_mod
base/modules/tools/psb_s_tools_mod.F90
+31 -20
View File
@@ -40,28 +40,31 @@ Module psb_s_tools_mod
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_salloc_vect(x, desc_a,info)
subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
import
implicit none
type(psb_s_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_salloc_vect
subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
import
implicit none
type(psb_s_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_salloc_vect_r2
subroutine psb_salloc_multivect(x, desc_a,info,n)
subroutine psb_salloc_multivect(x, desc_a,info,n, dupl, bldmode)
import
implicit none
type(psb_s_multivect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_salloc_multivect
end interface
@@ -123,7 +126,7 @@ Module psb_s_tools_mod
interface psb_geins
subroutine psb_sins_vect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_sins_vect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -132,10 +135,9 @@ Module psb_s_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_sins_vect
subroutine psb_sins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_sins_vect_v(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -144,10 +146,9 @@ Module psb_s_tools_mod
type(psb_l_vect_type), intent(inout) :: irw
type(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_sins_vect_v
subroutine psb_sins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_sins_vect_r2(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -156,10 +157,9 @@ Module psb_s_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_sins_vect_r2
subroutine psb_sins_multivect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_sins_multivect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -168,11 +168,10 @@ Module psb_s_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
real(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_sins_multivect
end interface
interface psb_cdbldext
Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info,extype)
import
@@ -239,29 +238,41 @@ Module psb_s_tools_mod
interface psb_spall
subroutine psb_sspalloc(a, desc_a, info, nnz)
subroutine psb_sspalloc(a, desc_a, info, nnz, dupl, bldmode)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz, bldmode
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_sspalloc
end interface
interface psb_spasb
subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl,mold)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
import
implicit none
type(psb_sspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl, upd
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_sspasb
end interface
interface psb_remote_mat
subroutine psb_ls_remote_mat(a,desc_a,b, info)
import
implicit none
type(psb_ls_coo_sparse_mat),Intent(inout) :: a
type(psb_desc_type),intent(inout) :: desc_a
type(psb_ls_coo_sparse_mat),Intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ls_remote_mat
end interface psb_remote_mat
interface psb_spfree
subroutine psb_sspfree(a, desc_a,info)
import
base/modules/tools/psb_z_tools_a_mod.f90
+15
View File
@@ -116,4 +116,19 @@ Module psb_z_tools_a_mod
end subroutine psb_zinsvi
end interface
interface psb_remote_vect
subroutine psb_z_remote_vect(n,v,iv,desc_a,x,ix, info)
import
implicit none
integer(psb_ipk_), intent(in) :: n
complex(psb_dpk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
complex(psb_dpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_remote_vect
end interface psb_remote_vect
end module psb_z_tools_a_mod
base/modules/tools/psb_z_tools_mod.F90
+31 -20
View File
@@ -40,28 +40,31 @@ Module psb_z_tools_mod
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_zalloc_vect(x, desc_a,info)
subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
import
implicit none
type(psb_z_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_zalloc_vect
subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
import
implicit none
type(psb_z_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_zalloc_vect_r2
subroutine psb_zalloc_multivect(x, desc_a,info,n)
subroutine psb_zalloc_multivect(x, desc_a,info,n, dupl, bldmode)
import
implicit none
type(psb_z_multivect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
end subroutine psb_zalloc_multivect
end interface
@@ -123,7 +126,7 @@ Module psb_z_tools_mod
interface psb_geins
subroutine psb_zins_vect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_zins_vect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -132,10 +135,9 @@ Module psb_z_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_zins_vect
subroutine psb_zins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_zins_vect_v(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -144,10 +146,9 @@ Module psb_z_tools_mod
type(psb_l_vect_type), intent(inout) :: irw
type(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_zins_vect_v
subroutine psb_zins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_zins_vect_r2(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -156,10 +157,9 @@ Module psb_z_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
complex(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_zins_vect_r2
subroutine psb_zins_multivect(m,irw,val,x,desc_a,info,dupl,local)
subroutine psb_zins_multivect(m,irw,val,x,desc_a,info,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
@@ -168,11 +168,10 @@ Module psb_z_tools_mod
integer(psb_lpk_), intent(in) :: irw(:)
complex(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_zins_multivect
end interface
interface psb_cdbldext
Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info,extype)
import
@@ -239,29 +238,41 @@ Module psb_z_tools_mod
interface psb_spall
subroutine psb_zspalloc(a, desc_a, info, nnz)
subroutine psb_zspalloc(a, desc_a, info, nnz, dupl, bldmode)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz, bldmode
integer(psb_ipk_), optional, intent(in) :: dupl
end subroutine psb_zspalloc
end interface
interface psb_spasb
subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl,mold)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
import
implicit none
type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl, upd
integer(psb_ipk_),optional, intent(in) :: upd
character(len=*), optional, intent(in) :: afmt
class(psb_z_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_zspasb
end interface
interface psb_remote_mat
subroutine psb_lz_remote_mat(a,desc_a,b, info)
import
implicit none
type(psb_lz_coo_sparse_mat),Intent(inout) :: a
type(psb_desc_type),intent(inout) :: desc_a
type(psb_lz_coo_sparse_mat),Intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lz_remote_mat
end interface psb_remote_mat
interface psb_spfree
subroutine psb_zspfree(a, desc_a,info)
import
base/psblas/Makefile
+3 -1
View File
@@ -24,7 +24,9 @@ MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
lib: $(OBJS)
objs: $(OBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
base/serial/Makefile
+7 -6
View File
@@ -20,18 +20,19 @@ INCDIR=..
MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
lib: impld sortd lib1 $(FOBJS)
objs: impld sortd $(FOBJS)
lib: objs
$(MAKE) -C impl lib
$(MAKE) -C sort lib
$(AR) $(LIBDIR)/$(LIBNAME) $(FOBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
#cood csrd jadd
lib1: $(FOBJS)
impld:
$(MAKE) -C impl lib
$(MAKE) -C impl objs
sortd:
$(MAKE) -C sort lib
$(MAKE) -C sort objs
clean:
/bin/rm -f $(FOBJS) *$(.mod)
($(MAKE) -C impl clean)
base/serial/impl/Makefile
+2 -2
View File
@@ -36,9 +36,9 @@ LIBFILE=$(LIBDIR)/$(LIBNAME)
#
default: lib
objs: $(OBJS)
lib: $(OBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
base/serial/impl/psb_c_coo_impl.F90
+37 -27
View File
@@ -728,7 +728,7 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc)
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
if (present(head)) write(iout,'(a,a)') '% ',head
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
@@ -3172,9 +3172,9 @@ subroutine psb_c_cp_coo_from_coo(a,b,info)
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nz
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
end do
end block
#else
@@ -3671,6 +3671,12 @@ subroutine psb_c_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
! Row major order
if (nr <= nzin) then
! Avoid strange situations with large indices
@@ -4357,6 +4363,11 @@ subroutine psb_c_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (nc <= nzin) then
! Avoid strange situations with large indices
@@ -5268,13 +5279,13 @@ function psb_lc_coo_maxval(a) result(res)
implicit none
class(psb_lc_coo_sparse_mat), intent(in) :: a
real(psb_spk_) :: res
integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='c_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = sone
else
@@ -5284,18 +5295,18 @@ function psb_lc_coo_maxval(a) result(res)
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
#else
res = maxval(abs(a%val(1:nnz)))
#endif
end if
end function psb_lc_coo_maxval
function psb_lc_coo_csnmi(a) result(res)
@@ -5351,13 +5362,13 @@ function psb_lc_coo_csnmi(a) result(res)
vt(i) = vt(i) + abs(a%val(j))
end do
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
#else
res = maxval(vt(1:m))
#endif
@@ -5403,11 +5414,11 @@ function psb_lc_coo_csnm1(a) result(res)
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
!$omp parallel do private(i)
do i=1, n
res = max(res,abs(vt(i)))
end do
end block
end block
#else
res = maxval(vt(1:n))
#endif
@@ -6661,7 +6672,7 @@ contains
integer(psb_lpk_), optional :: iren(:)
integer(psb_lpk_) :: nzin_, nza, idx,ip,jp,i,k, nzt, irw, lrw, nra, nca, nrd
integer(psb_ipk_) :: debug_level, debug_unit, inza
character(len=20) :: name='coo_getrow'
character(len=20) :: name='lcoo_getrow'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -6856,7 +6867,7 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz < 0) then
info = psb_err_iarg_neg_
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
@@ -6878,7 +6889,6 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz == 0) return
nza = a%get_nzeros()
isza = a%get_size()
if (a%is_bld()) then
base/serial/impl/psb_c_csr_impl.F90
+11 -3
View File
@@ -1328,8 +1328,8 @@ function psb_c_csr_csnmi(a) result(res)
res = szero
if (a%is_dev()) call a%sync()
!$omp parallel do private(i,acc) reduction(max: res)
do i = 1, a%get_nrows()
!$omp parallel do private(i,j,acc) reduction(max: res)
do i = 1, a%get_nrows()
acc = szero
do j=a%irp(i),a%irp(i+1)-1
acc = acc + abs(a%val(j))
@@ -1562,8 +1562,12 @@ subroutine psb_c_csr_get_diag(a,d,info)
if (a%is_unit()) then
d(1:mnm) = cone
!$omp parallel do private(i)
do i=1, mnm
d(i) = cone
end do
else
!$omp parallel do private(i,j,k)
do i=1, mnm
d(i) = czero
do k=a%irp(i),a%irp(i+1)-1
@@ -1574,6 +1578,7 @@ subroutine psb_c_csr_get_diag(a,d,info)
enddo
end do
end if
!$omp parallel do private(i)
do i=mnm+1,size(d)
d(i) = czero
end do
@@ -1629,6 +1634,7 @@ subroutine psb_c_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1, m
do j = a%irp(i), a%irp(i+1) -1
a%val(j) = a%val(j) * d(i)
@@ -1643,6 +1649,7 @@ subroutine psb_c_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1,a%get_nzeros()
j = a%ja(i)
a%val(i) = a%val(i) * d(j)
@@ -1681,6 +1688,7 @@ subroutine psb_c_csr_scals(d,a,info)
call a%make_nonunit()
end if
!$omp parallel do private(i)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
base/serial/impl/psb_c_mat_impl.F90
+6 -1
View File
@@ -675,7 +675,12 @@ subroutine psb_c_free(a)
call a%a%free()
deallocate(a%a)
endif
if (allocated(a%rmta)) then
call a%rmta%free()
deallocate(a%rmta)
end if
a%remote_build = psb_matbld_noremote_
end subroutine psb_c_free
base/serial/impl/psb_d_coo_impl.F90
+37 -27
View File
@@ -728,7 +728,7 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc)
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
if (present(head)) write(iout,'(a,a)') '% ',head
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
@@ -3172,9 +3172,9 @@ subroutine psb_d_cp_coo_from_coo(a,b,info)
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nz
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
end do
end block
#else
@@ -3671,6 +3671,12 @@ subroutine psb_d_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
! Row major order
if (nr <= nzin) then
! Avoid strange situations with large indices
@@ -4357,6 +4363,11 @@ subroutine psb_d_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (nc <= nzin) then
! Avoid strange situations with large indices
@@ -5268,13 +5279,13 @@ function psb_ld_coo_maxval(a) result(res)
implicit none
class(psb_ld_coo_sparse_mat), intent(in) :: a
real(psb_dpk_) :: res
integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='d_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = done
else
@@ -5284,18 +5295,18 @@ function psb_ld_coo_maxval(a) result(res)
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
#else
res = maxval(abs(a%val(1:nnz)))
#endif
end if
end function psb_ld_coo_maxval
function psb_ld_coo_csnmi(a) result(res)
@@ -5351,13 +5362,13 @@ function psb_ld_coo_csnmi(a) result(res)
vt(i) = vt(i) + abs(a%val(j))
end do
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
#else
res = maxval(vt(1:m))
#endif
@@ -5403,11 +5414,11 @@ function psb_ld_coo_csnm1(a) result(res)
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
!$omp parallel do private(i)
do i=1, n
res = max(res,abs(vt(i)))
end do
end block
end block
#else
res = maxval(vt(1:n))
#endif
@@ -6661,7 +6672,7 @@ contains
integer(psb_lpk_), optional :: iren(:)
integer(psb_lpk_) :: nzin_, nza, idx,ip,jp,i,k, nzt, irw, lrw, nra, nca, nrd
integer(psb_ipk_) :: debug_level, debug_unit, inza
character(len=20) :: name='coo_getrow'
character(len=20) :: name='lcoo_getrow'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -6856,7 +6867,7 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz < 0) then
info = psb_err_iarg_neg_
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
@@ -6878,7 +6889,6 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz == 0) return
nza = a%get_nzeros()
isza = a%get_size()
if (a%is_bld()) then
base/serial/impl/psb_d_csr_impl.F90
+11 -3
View File
@@ -1328,8 +1328,8 @@ function psb_d_csr_csnmi(a) result(res)
res = dzero
if (a%is_dev()) call a%sync()
!$omp parallel do private(i,acc) reduction(max: res)
do i = 1, a%get_nrows()
!$omp parallel do private(i,j,acc) reduction(max: res)
do i = 1, a%get_nrows()
acc = dzero
do j=a%irp(i),a%irp(i+1)-1
acc = acc + abs(a%val(j))
@@ -1562,8 +1562,12 @@ subroutine psb_d_csr_get_diag(a,d,info)
if (a%is_unit()) then
d(1:mnm) = done
!$omp parallel do private(i)
do i=1, mnm
d(i) = done
end do
else
!$omp parallel do private(i,j,k)
do i=1, mnm
d(i) = dzero
do k=a%irp(i),a%irp(i+1)-1
@@ -1574,6 +1578,7 @@ subroutine psb_d_csr_get_diag(a,d,info)
enddo
end do
end if
!$omp parallel do private(i)
do i=mnm+1,size(d)
d(i) = dzero
end do
@@ -1629,6 +1634,7 @@ subroutine psb_d_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1, m
do j = a%irp(i), a%irp(i+1) -1
a%val(j) = a%val(j) * d(i)
@@ -1643,6 +1649,7 @@ subroutine psb_d_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1,a%get_nzeros()
j = a%ja(i)
a%val(i) = a%val(i) * d(j)
@@ -1681,6 +1688,7 @@ subroutine psb_d_csr_scals(d,a,info)
call a%make_nonunit()
end if
!$omp parallel do private(i)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
base/serial/impl/psb_d_mat_impl.F90
+6 -1
View File
@@ -675,7 +675,12 @@ subroutine psb_d_free(a)
call a%a%free()
deallocate(a%a)
endif
if (allocated(a%rmta)) then
call a%rmta%free()
deallocate(a%rmta)
end if
a%remote_build = psb_matbld_noremote_
end subroutine psb_d_free
base/serial/impl/psb_s_coo_impl.F90
+37 -27
View File
@@ -728,7 +728,7 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc)
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
if (present(head)) write(iout,'(a,a)') '% ',head
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
@@ -3172,9 +3172,9 @@ subroutine psb_s_cp_coo_from_coo(a,b,info)
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nz
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
end do
end block
#else
@@ -3671,6 +3671,12 @@ subroutine psb_s_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
! Row major order
if (nr <= nzin) then
! Avoid strange situations with large indices
@@ -4357,6 +4363,11 @@ subroutine psb_s_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (nc <= nzin) then
! Avoid strange situations with large indices
@@ -5268,13 +5279,13 @@ function psb_ls_coo_maxval(a) result(res)
implicit none
class(psb_ls_coo_sparse_mat), intent(in) :: a
real(psb_spk_) :: res
integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='s_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = sone
else
@@ -5284,18 +5295,18 @@ function psb_ls_coo_maxval(a) result(res)
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
#else
res = maxval(abs(a%val(1:nnz)))
#endif
end if
end function psb_ls_coo_maxval
function psb_ls_coo_csnmi(a) result(res)
@@ -5351,13 +5362,13 @@ function psb_ls_coo_csnmi(a) result(res)
vt(i) = vt(i) + abs(a%val(j))
end do
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
#else
res = maxval(vt(1:m))
#endif
@@ -5403,11 +5414,11 @@ function psb_ls_coo_csnm1(a) result(res)
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
!$omp parallel do private(i)
do i=1, n
res = max(res,abs(vt(i)))
end do
end block
end block
#else
res = maxval(vt(1:n))
#endif
@@ -6661,7 +6672,7 @@ contains
integer(psb_lpk_), optional :: iren(:)
integer(psb_lpk_) :: nzin_, nza, idx,ip,jp,i,k, nzt, irw, lrw, nra, nca, nrd
integer(psb_ipk_) :: debug_level, debug_unit, inza
character(len=20) :: name='coo_getrow'
character(len=20) :: name='lcoo_getrow'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -6856,7 +6867,7 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz < 0) then
info = psb_err_iarg_neg_
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
@@ -6878,7 +6889,6 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz == 0) return
nza = a%get_nzeros()
isza = a%get_size()
if (a%is_bld()) then
base/serial/impl/psb_s_csr_impl.F90
+11 -3
View File
@@ -1328,8 +1328,8 @@ function psb_s_csr_csnmi(a) result(res)
res = szero
if (a%is_dev()) call a%sync()
!$omp parallel do private(i,acc) reduction(max: res)
do i = 1, a%get_nrows()
!$omp parallel do private(i,j,acc) reduction(max: res)
do i = 1, a%get_nrows()
acc = szero
do j=a%irp(i),a%irp(i+1)-1
acc = acc + abs(a%val(j))
@@ -1562,8 +1562,12 @@ subroutine psb_s_csr_get_diag(a,d,info)
if (a%is_unit()) then
d(1:mnm) = sone
!$omp parallel do private(i)
do i=1, mnm
d(i) = sone
end do
else
!$omp parallel do private(i,j,k)
do i=1, mnm
d(i) = szero
do k=a%irp(i),a%irp(i+1)-1
@@ -1574,6 +1578,7 @@ subroutine psb_s_csr_get_diag(a,d,info)
enddo
end do
end if
!$omp parallel do private(i)
do i=mnm+1,size(d)
d(i) = szero
end do
@@ -1629,6 +1634,7 @@ subroutine psb_s_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1, m
do j = a%irp(i), a%irp(i+1) -1
a%val(j) = a%val(j) * d(i)
@@ -1643,6 +1649,7 @@ subroutine psb_s_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1,a%get_nzeros()
j = a%ja(i)
a%val(i) = a%val(i) * d(j)
@@ -1681,6 +1688,7 @@ subroutine psb_s_csr_scals(d,a,info)
call a%make_nonunit()
end if
!$omp parallel do private(i)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
base/serial/impl/psb_s_mat_impl.F90
+6 -1
View File
@@ -675,7 +675,12 @@ subroutine psb_s_free(a)
call a%a%free()
deallocate(a%a)
endif
if (allocated(a%rmta)) then
call a%rmta%free()
deallocate(a%rmta)
end if
a%remote_build = psb_matbld_noremote_
end subroutine psb_s_free
base/serial/impl/psb_z_coo_impl.F90
+37 -27
View File
@@ -728,7 +728,7 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc)
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
if (present(head)) write(iout,'(a,a)') '% ',head
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
@@ -3172,9 +3172,9 @@ subroutine psb_z_cp_coo_from_coo(a,b,info)
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nz
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
a%ia(i) = b%ia(i)
a%ja(i) = b%ja(i)
a%val(i) = b%val(i)
end do
end block
#else
@@ -3671,6 +3671,12 @@ subroutine psb_z_fix_coo_inner_rowmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
! Row major order
if (nr <= nzin) then
! Avoid strange situations with large indices
@@ -4357,6 +4363,11 @@ subroutine psb_z_fix_coo_inner_colmajor(nr,nc,nzin,dupl,ia,ja,val,iaux,nzout,inf
integer(psb_ipk_) :: saved_elem,old_val,nxt_val,err,act_row,act_col,maxthreads
integer(psb_ipk_), allocatable :: sum(:),kaux(:),idxaux(:)
#endif
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (nc <= nzin) then
! Avoid strange situations with large indices
@@ -5268,13 +5279,13 @@ function psb_lz_coo_maxval(a) result(res)
implicit none
class(psb_lz_coo_sparse_mat), intent(in) :: a
real(psb_dpk_) :: res
integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='z_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = done
else
@@ -5284,18 +5295,18 @@ function psb_lz_coo_maxval(a) result(res)
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, nnz
res = max(res,abs(a%val(i)))
end do
end block
#else
res = maxval(abs(a%val(1:nnz)))
#endif
end if
end function psb_lz_coo_maxval
function psb_lz_coo_csnmi(a) result(res)
@@ -5351,13 +5362,13 @@ function psb_lz_coo_csnmi(a) result(res)
vt(i) = vt(i) + abs(a%val(j))
end do
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
block
integer(psb_ipk_) :: i
!$omp parallel do private(i)
do i=1, m
res = max(res,abs(vt(i)))
end do
end block
#else
res = maxval(vt(1:m))
#endif
@@ -5403,11 +5414,11 @@ function psb_lz_coo_csnm1(a) result(res)
#if defined(OPENMP)
block
integer(psb_ipk_) :: i
!$omp parallel do private(i) reduction(max: res)
!$omp parallel do private(i)
do i=1, n
res = max(res,abs(vt(i)))
end do
end block
end block
#else
res = maxval(vt(1:n))
#endif
@@ -6661,7 +6672,7 @@ contains
integer(psb_lpk_), optional :: iren(:)
integer(psb_lpk_) :: nzin_, nza, idx,ip,jp,i,k, nzt, irw, lrw, nra, nca, nrd
integer(psb_ipk_) :: debug_level, debug_unit, inza
character(len=20) :: name='coo_getrow'
character(len=20) :: name='lcoo_getrow'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -6856,7 +6867,7 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz < 0) then
info = psb_err_iarg_neg_
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
3 call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
@@ -6878,7 +6889,6 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
if (nz == 0) return
nza = a%get_nzeros()
isza = a%get_size()
if (a%is_bld()) then
base/serial/impl/psb_z_csr_impl.F90
+11 -3
View File
@@ -1328,8 +1328,8 @@ function psb_z_csr_csnmi(a) result(res)
res = dzero
if (a%is_dev()) call a%sync()
!$omp parallel do private(i,acc) reduction(max: res)
do i = 1, a%get_nrows()
!$omp parallel do private(i,j,acc) reduction(max: res)
do i = 1, a%get_nrows()
acc = dzero
do j=a%irp(i),a%irp(i+1)-1
acc = acc + abs(a%val(j))
@@ -1562,8 +1562,12 @@ subroutine psb_z_csr_get_diag(a,d,info)
if (a%is_unit()) then
d(1:mnm) = zone
!$omp parallel do private(i)
do i=1, mnm
d(i) = zone
end do
else
!$omp parallel do private(i,j,k)
do i=1, mnm
d(i) = zzero
do k=a%irp(i),a%irp(i+1)-1
@@ -1574,6 +1578,7 @@ subroutine psb_z_csr_get_diag(a,d,info)
enddo
end do
end if
!$omp parallel do private(i)
do i=mnm+1,size(d)
d(i) = zzero
end do
@@ -1629,6 +1634,7 @@ subroutine psb_z_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1, m
do j = a%irp(i), a%irp(i+1) -1
a%val(j) = a%val(j) * d(i)
@@ -1643,6 +1649,7 @@ subroutine psb_z_csr_scal(d,a,info,side)
goto 9999
end if
!$omp parallel do private(i,j)
do i=1,a%get_nzeros()
j = a%ja(i)
a%val(i) = a%val(i) * d(j)
@@ -1681,6 +1688,7 @@ subroutine psb_z_csr_scals(d,a,info)
call a%make_nonunit()
end if
!$omp parallel do private(i)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
base/serial/impl/psb_z_mat_impl.F90
+6 -1
View File
@@ -675,7 +675,12 @@ subroutine psb_z_free(a)
call a%a%free()
deallocate(a%a)
endif
if (allocated(a%rmta)) then
call a%rmta%free()
deallocate(a%rmta)
end if
a%remote_build = psb_matbld_noremote_
end subroutine psb_z_free
base/serial/sort/Makefile
+2 -2
View File
@@ -27,9 +27,9 @@ LIBFILE=$(LIBDIR)/$(LIBNAME)
#
default: lib
objs: $(OBJS)
lib: $(OBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
base/serial/sort/psb_i_hsort_impl.f90
-678
View File
@@ -1,678 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! The merge-sort and quicksort routines are implemented in the
! serial/aux directory
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_ihsort(x,ix,dir,flag)
use psb_sort_mod, psb_protect_name => psb_ihsort
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
integer(psb_ipk_) :: key
integer(psb_ipk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_hsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case(psb_sort_up_,psb_sort_down_)
! OK
case (psb_asort_up_,psb_asort_down_)
! OK
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
!
! Dirty trick to sort with heaps: if we want
! to sort in place upwards, first we set up a heap so that
! we can easily get the LARGEST element, then we take it out
! and put it in the last entry, and so on.
! So, we invert dir_
!
dir_ = -dir_
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_ == psb_sort_ovw_idx_) then
do i=1, n
ix(i) = i
end do
end if
l = 0
do i=1, n
key = x(i)
index = ix(i)
call psi_idx_insert_heap(key,index,l,x,ix,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! '
end if
end do
do i=n, 2, -1
call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
ix(i) = index
end do
else if (.not.present(ix)) then
l = 0
do i=1, n
key = x(i)
call psi_insert_heap(key,l,x,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i
end if
end do
do i=n, 2, -1
call psi_i_heap_get_first(key,l,x,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
end do
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_ihsort
!
! These are packaged so that they can be used to implement
! a heapsort, should the need arise
!
!
! Programming note:
! In the implementation of the heap_get_first function
! we have code like this
!
! if ( ( heap(2*i) < heap(2*i+1) ) .or.&
! & (2*i == last)) then
! j = 2*i
! else
! j = 2*i + 1
! end if
!
! It looks like the 2*i+1 could overflow the array, but this
! is not true because there is a guard statement
! if (i>last/2) exit
! and because last has just been reduced by 1 when defining the return value,
! therefore 2*i+1 may be greater than the current value of last,
! but cannot be greater than the value of last when the routine was entered
! hence it is safe.
!
!
!
subroutine psi_i_insert_heap(key,last,heap,dir,info)
use psb_sort_mod, psb_protect_name => psi_i_insert_heap
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2
integer(psb_ipk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_insert_heap
subroutine psi_i_heap_get_first(key,last,heap,dir,info)
use psb_sort_mod, psb_protect_name => psi_i_heap_get_first
implicit none
integer(psb_ipk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
integer(psb_ipk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
info = -1
return
endif
key = heap(1)
heap(1) = heap(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_heap_get_first
subroutine psi_i_idx_insert_heap(key,index,last,heap,idxs,dir,info)
use psb_sort_mod, psb_protect_name => psi_i_idx_insert_heap
implicit none
!
! Input:
! key: the new value
! index: the new index
! last: pointer to the last occupied element in heap
! heap: the heap
! idxs: the indices
! dir: sorting direction
integer(psb_ipk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2, itemp
integer(psb_ipk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
idxs(i) = index
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_idx_insert_heap
subroutine psi_i_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
use psb_sort_mod, psb_protect_name => psi_i_idx_heap_get_first
implicit none
integer(psb_ipk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(out) :: key
integer(psb_ipk_) :: i, j,itemp
integer(psb_ipk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
index = 0
info = -1
return
endif
key = heap(1)
index = idxs(1)
heap(1) = heap(last)
idxs(1) = idxs(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_i_idx_heap_get_first
base/serial/sort/psb_i_isort_impl.f90
-341
View File
@@ -1,341 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_iisort(x,ix,dir,flag)
use psb_sort_mod, psb_protect_name => psb_iisort
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, err_act
integer(psb_ipk_) :: n, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_iisort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_sort_up_)
call psi_iisrx_up(n,x,ix)
case (psb_sort_down_)
call psi_iisrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_iaisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_iaisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_sort_up_)
call psi_iisr_up(n,x)
case (psb_sort_down_)
call psi_iisr_dw(n,x)
case (psb_asort_up_)
call psi_iaisr_up(n,x)
case (psb_asort_down_)
call psi_iaisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_iisort
subroutine psi_iisrx_up(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_iisrx_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iisrx_up
subroutine psi_iisrx_dw(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_iisrx_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iisrx_dw
subroutine psi_iisr_up(n,x)
use psb_sort_mod, psb_protect_name => psi_iisr_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iisr_up
subroutine psi_iisr_dw(n,x)
use psb_sort_mod, psb_protect_name => psi_iisr_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iisr_dw
subroutine psi_iaisrx_up(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_iaisrx_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iaisrx_up
subroutine psi_iaisrx_dw(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_iaisrx_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_iaisrx_dw
subroutine psi_iaisr_up(n,x)
use psb_sort_mod, psb_protect_name => psi_iaisr_up
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iaisr_up
subroutine psi_iaisr_dw(n,x)
use psb_sort_mod, psb_protect_name => psi_iaisr_dw
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j
integer(psb_ipk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_iaisr_dw
base/serial/sort/psb_i_msort_impl.f90
-713
View File
@@ -1,713 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
logical function psb_iisaperm(n,eip)
use psb_sort_mod, psb_protect_name => psb_iisaperm
implicit none
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: eip(n)
integer(psb_ipk_), allocatable :: ip(:)
integer(psb_ipk_) :: i,j,m, info
psb_iisaperm = .true.
if (n <= 0) return
allocate(ip(n), stat=info)
if (info /= psb_success_) return
!
! sanity check first
!
do i=1, n
ip(i) = eip(i)
if ((ip(i) < 1).or.(ip(i) > n)) then
write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n
psb_iisaperm = .false.
return
endif
enddo
!
! now work through the cycles, by marking each successive item as negative.
! no cycle should intersect with any other, hence the >= 1 check.
!
do m = 1, n
i = ip(m)
if (i < 0) then
ip(m) = -i
else if (i /= m) then
j = ip(i)
ip(i) = -j
i = j
do while ((j >= 1).and.(j /= m))
j = ip(i)
ip(i) = -j
i = j
enddo
ip(m) = abs(ip(m))
if (j /= m) then
psb_iisaperm = .false.
goto 9999
endif
end if
enddo
9999 continue
return
end function psb_iisaperm
subroutine psb_imsort_u(x,nout,dir)
use psb_sort_mod, psb_protect_name => psb_imsort_u
use psb_error_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_ipk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_imsort_u
function psb_ibsrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_ibsrch
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m, i
ipos = -1
if (n<5) then
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end if
lb = 1
ub = n
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function psb_ibsrch
function psb_issrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_issrch
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_ipk_) :: key
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end function psb_issrch
subroutine psb_imsort(x,ix,dir,flag)
use psb_sort_mod, psb_protect_name => psb_imsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_ipk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_imsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_i_msort')
goto 9999
endif
select case(dir_)
case (psb_sort_up_)
call psi_i_msort_up(n,x,iaux,iret)
case (psb_sort_down_)
call psi_i_msort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call psi_i_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call psi_i_amsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,ix,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_imsort
subroutine psi_i_msort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_i_msort_up
subroutine psi_i_msort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_i_msort_dw
subroutine psi_i_amsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_i_amsort_up
subroutine psi_i_amsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_ipk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
!
integer(psb_ipk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_i_amsort_dw
base/serial/sort/psb_i_qsort_impl.f90
-1318
View File
File diff suppressed because it is too large Load Diff
base/serial/sort/psb_l_hsort_impl.f90
-678
View File
@@ -1,678 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! The merge-sort and quicksort routines are implemented in the
! serial/aux directory
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_lhsort(x,ix,dir,flag)
use psb_sort_mod, psb_protect_name => psb_lhsort
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
integer(psb_lpk_) :: key
integer(psb_lpk_) :: index
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_hsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case(psb_sort_up_,psb_sort_down_)
! OK
case (psb_asort_up_,psb_asort_down_)
! OK
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
!
! Dirty trick to sort with heaps: if we want
! to sort in place upwards, first we set up a heap so that
! we can easily get the LARGEST element, then we take it out
! and put it in the last entry, and so on.
! So, we invert dir_
!
dir_ = -dir_
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_ == psb_sort_ovw_idx_) then
do i=1, n
ix(i) = i
end do
end if
l = 0
do i=1, n
key = x(i)
index = ix(i)
call psi_idx_insert_heap(key,index,l,x,ix,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! '
end if
end do
do i=n, 2, -1
call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
ix(i) = index
end do
else if (.not.present(ix)) then
l = 0
do i=1, n
key = x(i)
call psi_insert_heap(key,l,x,dir_,info)
if (l /= i) then
write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i
end if
end do
do i=n, 2, -1
call psi_l_heap_get_first(key,l,x,dir_,info)
if (l /= i-1) then
write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i
end if
x(i) = key
end do
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_lhsort
!
! These are packaged so that they can be used to implement
! a heapsort, should the need arise
!
!
! Programming note:
! In the implementation of the heap_get_first function
! we have code like this
!
! if ( ( heap(2*i) < heap(2*i+1) ) .or.&
! & (2*i == last)) then
! j = 2*i
! else
! j = 2*i + 1
! end if
!
! It looks like the 2*i+1 could overflow the array, but this
! is not true because there is a guard statement
! if (i>last/2) exit
! and because last has just been reduced by 1 when defining the return value,
! therefore 2*i+1 may be greater than the current value of last,
! but cannot be greater than the value of last when the routine was entered
! hence it is safe.
!
!
!
subroutine psi_l_insert_heap(key,last,heap,dir,info)
use psb_sort_mod, psb_protect_name => psi_l_insert_heap
implicit none
!
! Input:
! key: the new value
! last: pointer to the last occupied element in heap
! heap: the heap
! dir: sorting direction
integer(psb_lpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: dir
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_lpk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2
integer(psb_lpk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_l_insert_heap
subroutine psi_l_heap_get_first(key,last,heap,dir,info)
use psb_sort_mod, psb_protect_name => psi_l_heap_get_first
implicit none
integer(psb_lpk_), intent(inout) :: key
integer(psb_lpk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j
integer(psb_lpk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
info = -1
return
endif
key = heap(1)
heap(1) = heap(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_l_heap_get_first
subroutine psi_l_idx_insert_heap(key,index,last,heap,idxs,dir,info)
use psb_sort_mod, psb_protect_name => psi_l_idx_insert_heap
implicit none
!
! Input:
! key: the new value
! index: the new index
! last: pointer to the last occupied element in heap
! heap: the heap
! idxs: the indices
! dir: sorting direction
integer(psb_lpk_), intent(in) :: key
integer(psb_ipk_), intent(in) :: index,dir
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(inout) :: idxs(:),last
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, i2, itemp
integer(psb_lpk_) :: temp
info = psb_success_
if (last < 0) then
write(psb_err_unit,*) 'Invalid last in heap ',last
info = last
return
endif
last = last + 1
if (last > size(heap)) then
write(psb_err_unit,*) 'out of bounds '
info = -1
return
end if
i = last
heap(i) = key
idxs(i) = index
select case(dir)
case (psb_sort_up_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) < heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_sort_down_)
do
if (i<=1) exit
i2 = i/2
if (heap(i) > heap(i2)) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_up_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) < abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case (psb_asort_down_)
do
if (i<=1) exit
i2 = i/2
if (abs(heap(i)) > abs(heap(i2))) then
itemp = idxs(i)
idxs(i) = idxs(i2)
idxs(i2) = itemp
temp = heap(i)
heap(i) = heap(i2)
heap(i2) = temp
i = i2
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_l_idx_insert_heap
subroutine psi_l_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
use psb_sort_mod, psb_protect_name => psi_l_idx_heap_get_first
implicit none
integer(psb_lpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: index,info
integer(psb_ipk_), intent(inout) :: last,idxs(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_lpk_), intent(out) :: key
integer(psb_ipk_) :: i, j,itemp
integer(psb_lpk_) :: temp
info = psb_success_
if (last <= 0) then
key = 0
index = 0
info = -1
return
endif
key = heap(1)
index = idxs(1)
heap(1) = heap(last)
idxs(1) = idxs(last)
last = last - 1
select case(dir)
case (psb_sort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) < heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) > heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_sort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (heap(2*i) > heap(2*i+1)) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (heap(i) < heap(j)) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_up_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) > abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case (psb_asort_down_)
i = 1
do
if (i > (last/2)) exit
if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.&
& (2*i == last)) then
j = 2*i
else
j = 2*i + 1
end if
if (abs(heap(i)) < abs(heap(j))) then
itemp = idxs(i)
idxs(i) = idxs(j)
idxs(j) = itemp
temp = heap(i)
heap(i) = heap(j)
heap(j) = temp
i = j
else
exit
end if
end do
case default
write(psb_err_unit,*) 'Invalid direction in heap ',dir
end select
return
end subroutine psi_l_idx_heap_get_first
base/serial/sort/psb_l_isort_impl.f90
-341
View File
@@ -1,341 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! The insertion sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
subroutine psb_lisort(x,ix,dir,flag)
use psb_sort_mod, psb_protect_name => psb_lisort
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, err_act
integer(psb_lpk_) :: n, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_lisort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (flag_==psb_sort_ovw_idx_) then
do i=1,n
ix(i) = i
end do
end if
select case(dir_)
case (psb_sort_up_)
call psi_lisrx_up(n,x,ix)
case (psb_sort_down_)
call psi_lisrx_dw(n,x,ix)
case (psb_asort_up_)
call psi_laisrx_up(n,x,ix)
case (psb_asort_down_)
call psi_laisrx_dw(n,x,ix)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
else
select case(dir_)
case (psb_sort_up_)
call psi_lisr_up(n,x)
case (psb_sort_down_)
call psi_lisr_dw(n,x)
case (psb_asort_up_)
call psi_laisr_up(n,x)
case (psb_asort_down_)
call psi_laisr_dw(n,x)
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_lisort
subroutine psi_lisrx_up(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_lisrx_up
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j,ix
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_lisrx_up
subroutine psi_lisrx_dw(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_lisrx_dw
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j,ix
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_lisrx_dw
subroutine psi_lisr_up(n,x)
use psb_sort_mod, psb_protect_name => psi_lisr_up
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_lisr_up
subroutine psi_lisr_dw(n,x)
use psb_sort_mod, psb_protect_name => psi_lisr_dw
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_lisr_dw
subroutine psi_laisrx_up(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_laisrx_up
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j,ix
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_laisrx_up
subroutine psi_laisrx_dw(n,x,idx)
use psb_sort_mod, psb_protect_name => psi_laisrx_dw
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j,ix
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
endif
enddo
end subroutine psi_laisrx_dw
subroutine psi_laisr_up(n,x)
use psb_sort_mod, psb_protect_name => psi_laisr_up
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_laisr_up
subroutine psi_laisr_dw(n,x)
use psb_sort_mod, psb_protect_name => psi_laisr_dw
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_) :: i,j
integer(psb_lpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
endif
enddo
end subroutine psi_laisr_dw
base/serial/sort/psb_l_msort_impl.f90
-713
View File
@@ -1,713 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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.
!
!
!
! The merge-sort routines
! References:
! D. Knuth
! The Art of Computer Programming, vol. 3
! Addison-Wesley
!
! Aho, Hopcroft, Ullman
! Data Structures and Algorithms
! Addison-Wesley
!
logical function psb_lisaperm(n,eip)
use psb_sort_mod, psb_protect_name => psb_lisaperm
implicit none
integer(psb_lpk_), intent(in) :: n
integer(psb_lpk_), intent(in) :: eip(n)
integer(psb_lpk_), allocatable :: ip(:)
integer(psb_lpk_) :: i,j,m, info
psb_lisaperm = .true.
if (n <= 0) return
allocate(ip(n), stat=info)
if (info /= psb_success_) return
!
! sanity check first
!
do i=1, n
ip(i) = eip(i)
if ((ip(i) < 1).or.(ip(i) > n)) then
write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n
psb_lisaperm = .false.
return
endif
enddo
!
! now work through the cycles, by marking each successive item as negative.
! no cycle should intersect with any other, hence the >= 1 check.
!
do m = 1, n
i = ip(m)
if (i < 0) then
ip(m) = -i
else if (i /= m) then
j = ip(i)
ip(i) = -j
i = j
do while ((j >= 1).and.(j /= m))
j = ip(i)
ip(i) = -j
i = j
enddo
ip(m) = abs(ip(m))
if (j /= m) then
psb_lisaperm = .false.
goto 9999
endif
end if
enddo
9999 continue
return
end function psb_lisaperm
subroutine psb_lmsort_u(x,nout,dir)
use psb_sort_mod, psb_protect_name => psb_lmsort_u
use psb_error_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_lpk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
integer(psb_lpk_) :: n, k
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_msort_u'
call psb_erractionsave(err_act)
n = size(x)
call psb_msort(x,dir=dir)
nout = min(1,n)
do k=2,n
if (x(k) /= x(nout)) then
nout = nout + 1
x(nout) = x(k)
endif
enddo
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_lmsort_u
function psb_lbsrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_lbsrch
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_lpk_) :: key
integer(psb_lpk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m, i
ipos = -1
if (n<5) then
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end if
lb = 1
ub = n
do while (lb.le.ub)
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
lb = ub + 1
else if (key < v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end function psb_lbsrch
function psb_lssrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_lssrch
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_lpk_) :: key
integer(psb_lpk_) :: v(:)
integer(psb_ipk_) :: i
ipos = -1
do i=1,n
if (key.eq.v(i)) then
ipos = i
return
end if
enddo
return
end function psb_lssrch
subroutine psb_lmsort(x,ix,dir,flag)
use psb_sort_mod, psb_protect_name => psb_lmsort
use psb_error_mod
use psb_ip_reord_mod
implicit none
integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_lpk_), optional, intent(inout) :: ix(:)
integer(psb_ipk_) :: dir_, flag_, n, err_act
integer(psb_lpk_), allocatable :: iaux(:)
integer(psb_ipk_) :: iret, info, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
name='psb_lmsort'
call psb_erractionsave(err_act)
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
select case(dir_)
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
! OK keep going
case default
ierr(1) = 3; ierr(2) = dir_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
ierr(1) = 2; ierr(2) = size(ix);
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
goto 9999
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case(psb_sort_ovw_idx_)
do i=1,n
ix(i) = i
end do
case (psb_sort_keep_idx_)
! OK keep going
case default
ierr(1) = 4; ierr(2) = flag_;
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
goto 9999
end select
end if
allocate(iaux(0:n+1),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_l_msort')
goto 9999
endif
select case(dir_)
case (psb_sort_up_)
call psi_l_msort_up(n,x,iaux,iret)
case (psb_sort_down_)
call psi_l_msort_dw(n,x,iaux,iret)
case (psb_asort_up_)
call psi_l_amsort_up(n,x,iaux,iret)
case (psb_asort_down_)
call psi_l_amsort_dw(n,x,iaux,iret)
end select
!
! Do the actual reordering, since the inner routines
! only provide linked pointers.
!
if (iret == 0 ) then
if (present(ix)) then
call psb_ip_reord(n,x,ix,iaux)
else
call psb_ip_reord(n,x,iaux)
end if
end if
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_lmsort
subroutine psi_l_msort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
!
integer(psb_lpk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) <= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) > k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) <= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) > k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_l_msort_up
subroutine psi_l_msort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
!
integer(psb_lpk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (k(p) >= k(p+1)) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (k(p) < k(q)) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (k(p) >= k(q)) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (k(p) < k(q)) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_l_msort_dw
subroutine psi_l_amsort_up(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
!
integer(psb_lpk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) <= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) > abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) <= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) > abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_l_amsort_up
subroutine psi_l_amsort_dw(n,k,l,iret)
use psb_const_mod
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_lpk_) :: k(n)
integer(psb_lpk_) :: l(0:n+1)
!
integer(psb_lpk_) :: p,q,s,t
! ..
iret = 0
! first step: we are preparing ordered sublists, exploiting
! what order was already in the input data; negative links
! mark the end of the sublists
l(0) = 1
t = n + 1
do p = 1,n - 1
if (abs(k(p)) >= abs(k(p+1))) then
l(p) = p + 1
else
l(t) = - (p+1)
t = p
end if
end do
l(t) = 0
l(n) = 0
! see if the input was already sorted
if (l(n+1) == 0) then
iret = 1
return
else
l(n+1) = abs(l(n+1))
end if
mergepass: do
! otherwise, begin a pass through the list.
! throughout all the subroutine we have:
! p, q: pointing to the sublists being merged
! s: pointing to the most recently processed record
! t: pointing to the end of previously completed sublist
s = 0
t = n + 1
p = l(s)
q = l(t)
if (q == 0) exit mergepass
outer: do
if (abs(k(p)) < abs(k(q))) then
l(s) = sign(q,l(s))
s = q
q = l(q)
if (q > 0) then
do
if (abs(k(p)) >= abs(k(q))) cycle outer
s = q
q = l(q)
if (q <= 0) exit
end do
end if
l(s) = p
s = t
do
t = p
p = l(p)
if (p <= 0) exit
end do
else
l(s) = sign(p,l(s))
s = p
p = l(p)
if (p>0) then
do
if (abs(k(p)) < abs(k(q))) cycle outer
s = p
p = l(p)
if (p <= 0) exit
end do
end if
! otherwise, one sublist ended, and we append to it the rest
! of the other one.
l(s) = q
s = t
do
t = q
q = l(q)
if (q <= 0) exit
end do
end if
p = -p
q = -q
if (q == 0) then
l(s) = sign(p,l(s))
l(t) = 0
exit outer
end if
end do outer
end do mergepass
end subroutine psi_l_amsort_dw
base/serial/sort/psb_l_qsort_impl.f90
-1318
View File
File diff suppressed because it is too large Load Diff
base/tools/Makefile
+7 -2
View File
@@ -30,14 +30,19 @@ FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt
psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o
MPFOBJS = psb_icdasb.o psb_ssphalo.o psb_dsphalo.o psb_csphalo.o psb_zsphalo.o \
psb_dcdbldext.o psb_zcdbldext.o psb_scdbldext.o psb_ccdbldext.o
psb_dcdbldext.o psb_zcdbldext.o psb_scdbldext.o psb_ccdbldext.o \
psb_s_remote_mat.o psb_d_remote_mat.o psb_c_remote_mat.o psb_z_remote_mat.o \
psb_s_remote_vect.o psb_d_remote_vect.o psb_c_remote_vect.o psb_z_remote_vect.o \
psb_e_remote_vect.o psb_m_remote_vect.o
LIBDIR=..
INCDIR=..
MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(FIFLAG)$(MODDIR)
lib: mpfobjs $(FOBJS)
objs: mpfobjs $(FOBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(FOBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
base/tools/psb_c_remote_mat.F90
+276
View File
@@ -0,0 +1,276 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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_c_remote_mat.f90
!
! Subroutine:
! This routine does the retrieval of remote matrix rows.
! Retrieval is done through GETROW, therefore it should work
! for any matrix format in A; as for the output, default is CSR.
!
! There is also a specialized version lc_CSR whose interface
! is adapted for the needs of c_par_csr_spspmm.
!
! There are three possible exchange algorithms:
! 1. Use MPI_Alltoallv
! 2. Use psb_simple_a2av
! 3. Use psb_simple_triad_a2av
! Default choice is 3. The MPI variant has proved to be inefficient;
! that is because it is not persistent, therefore you pay the initialization price
! every time, and it is not optimized for a sparse communication pattern,
! most MPI implementations assume that all communications are non-empty.
! The PSB_SIMPLE variants reuse the same communicator, and go for a simplistic
! sequence of sends/receive that is quite efficient for a sparse communication
! pattern. To be refined/reviewed in the future to compare with neighbour
! persistent collectives.
!
! Arguments:
! a - type(psb_cspmat_type) The local part of input matrix A
! desc_a - type(psb_desc_type). The communication descriptor.
! blck - type(psb_cspmat_type) The local part of output matrix BLCK
! info - integer. Return code
! rowcnv - logical Should row/col indices be converted
! colcnv - logical to/from global numbering when sent/received?
! default is .TRUE.
! rowscale - logical Should row/col indices on output be remapped
! colscale - logical from MIN:MAX to 1:(MAX-MIN+1) ?
! default is .FALSE.
! (commmon use is ROWSCALE=.TRUE., COLSCALE=.FALSE.)
! data - integer Which index list in desc_a should be used to retrieve
! rows, default psb_comm_halo_
! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ DISABLED for this routine.
!
Subroutine psb_lc_remote_mat(a,desc_a,b,info)
use psb_base_mod, psb_protect_name => psb_lc_remote_mat
#ifdef MPI_MOD
use mpi
#endif
Implicit None
#ifdef MPI_H
include 'mpif.h'
#endif
Type(psb_lc_coo_sparse_mat),Intent(inout) :: a
Type(psb_lc_coo_sparse_mat),Intent(inout) :: b
Type(psb_desc_type), Intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
! ...local scalars....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, &
& n_elem, j, ipx,idxs,idxr
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth
integer(psb_ipk_) :: nrcvs, nsnds
integer(psb_mpk_) :: icomm, minfo
integer(psb_mpk_), allocatable :: brvindx(:), &
& rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:)
integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:)
complex(psb_spk_), allocatable :: valsnd(:)
type(psb_lc_coo_sparse_mat), allocatable :: acoo
class(psb_i_base_vect_type), pointer :: pdxv
integer(psb_ipk_), allocatable :: ila(:), iprc(:)
logical :: rowcnv_,colcnv_,rowscale_,colscale_
character(len=5) :: outfmt_
integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name, ch_err
info=psb_success_
name='psb_c_remote_mat'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt = desc_a%get_context()
icomm = desc_a%get_mpic()
Call psb_info(ctxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start'
call b%free()
Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),&
& bsdindx(np+1), acoo,stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
nz = a%get_nzeros()
!allocate(ila(nz))
!write(0,*) me,name,' size :',nz,size(ila)
!call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.)
!nouth = count(ila(1:nz)<0)
!write(0,*) me,name,' Count out of halo :',nouth
!call psb_max(ctxt,nouth)
!if ((nouth/=0).and.(me==0)) &
! & write(0,*) 'Warning: would require reinit of DESC_A'
call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info)
icomm = desc_a%get_mpic()
sdsz(:)=0
rvsz(:)=0
sdsi(:)=0
rvsi(:)=0
ipx = 1
brvindx(:) = 0
bsdindx(:) = 0
counter=1
idx = 0
idxs = 0
idxr = 0
do i=1,nz
if (iprc(i) >=0) then
sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1
else
write(0,*)me,name,' Error from fnd_owner: ',iprc(i)
end if
end do
call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
& rvsz,1,psb_mpi_mpk_,icomm,minfo)
if (minfo /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999
end if
!write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
nsnds = count(sdsz /= 0)
nrcvs = count(rvsz /= 0)
idxs = 0
idxr = 0
counter = 1
Do proc=0,np-1
bsdindx(proc+1) = idxs
idxs = idxs + sdsz(proc+1)
brvindx(proc+1) = idxr
idxr = idxr + rvsz(proc+1)
Enddo
iszs = sum(sdsz)
iszr = sum(rvsz)
call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr)
if (psb_errstatus_fatal()) then
write(0,*) 'Error from acoo%allocate '
info = 4010
goto 9999
end if
if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),&
& ' Send:',sdsz(:),' Receive:',rvsz(:)
!write(debug_unit,*) me,' ',trim(name),': ',info
if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info)
!write(debug_unit,*) me,' ',trim(name),' iasnd: ',info
if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info)
!write(debug_unit,*) me,' ',trim(name),' jasnd: ',info
if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info)
!write(debug_unit,*) me,' ',trim(name),' valsnd: ',info
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='ensure_size')
goto 9999
end if
do k=1, nz
proc = iprc(k)
sdsi(proc+1) = sdsi(proc+1) + 1
!rvsi(proc) = rvsi(proc) + 1
iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k)
jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k)
valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k)
end do
do proc=0,np-1
if (sdsi(proc+1) /= sdsz(proc+1)) &
& write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
end do
select case(psb_get_sp_a2av_alg())
case(psb_sp_a2av_smpl_triad_)
call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info)
case(psb_sp_a2av_smpl_v_)
call psb_simple_a2av(valsnd,sdsz,bsdindx,&
& acoo%val,rvsz,brvindx,ctxt,info)
if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,&
& acoo%ia,rvsz,brvindx,ctxt,info)
if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,&
& acoo%ja,rvsz,brvindx,ctxt,info)
case(psb_sp_a2av_mpi_)
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,&
& acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo)
if (minfo == mpi_success) &
& call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,&
& acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo == mpi_success) &
& call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,&
& acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo /= mpi_success) info = minfo
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='wrong A2AV alg selector')
goto 9999
end select
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='alltoallv')
goto 9999
end if
call acoo%set_nzeros(iszr)
call acoo%mv_to_coo(b,info)
Deallocate(brvindx,bsdindx,rvsz,sdsz,&
& iasnd,jasnd,valsnd,stat=info)
if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
End Subroutine psb_lc_remote_mat
base/tools/psb_c_remote_vect.F90
+223
View File
@@ -0,0 +1,223 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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_c_remote_vect.f90
!
! Subroutine:
! This routine does the retrieval of remote vector entries.
!
! There are three possible exchange algorithms:
! 1. Use MPI_Alltoallv
! 2. Use psb_simple_a2av
! 3. Use psb_simple_triad_a2av
! Default choice is 3. The MPI variant has proved to be inefficient;
! that is because it is not persistent, therefore you pay the initialization price
! every time, and it is not optimized for a sparse communication pattern,
! most MPI implementations assume that all communications are non-empty.
! The PSB_SIMPLE variants reuse the same communicator, and go for a simplistic
! sequence of sends/receive that is quite efficient for a sparse communication
! pattern. To be refined/reviewed in the future to compare with neighbour
! persistent collectives.
!
! Arguments:
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! rowcnv - logical Should row/col indices be converted
! colcnv - logical to/from global numbering when sent/received?
! default is .TRUE.
! rowscale - logical Should row/col indices on output be remapped
! colscale - logical from MIN:MAX to 1:(MAX-MIN+1) ?
! default is .FALSE.
! (commmon use is ROWSCALE=.TRUE., COLSCALE=.FALSE.)
! data - integer Which index list in desc_a should be used to retrieve
! rows, default psb_comm_halo_
! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ DISABLED for this routine.
!
subroutine psb_c_remote_vect(n,v,iv,desc_a,x,ix, info)
use psb_base_mod, psb_protect_name => psb_c_remote_vect
#ifdef MPI_MOD
use mpi
#endif
Implicit None
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: n
complex(psb_spk_), Intent(in) :: v(:)
integer(psb_lpk_), Intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a
complex(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info
! ...local scalars....
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, &
& j, idxs,idxr, k, iszs, iszr
integer(psb_ipk_) :: nrcvs, nsnds
integer(psb_mpk_) :: icomm, minfo
integer(psb_mpk_), allocatable :: brvindx(:), &
& rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:)
integer(psb_lpk_), allocatable :: lsnd(:)
complex(psb_spk_), allocatable :: valsnd(:)
integer(psb_ipk_), allocatable :: iprc(:)
integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name, ch_err
info=psb_success_
name='psb_c_remote_vect'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt = desc_a%get_context()
icomm = desc_a%get_mpic()
Call psb_info(ctxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start'
Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),&
& bsdindx(np+1), stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info)
icomm = desc_a%get_mpic()
sdsz(:) = 0
rvsz(:) = 0
sdsi(:) = 0
rvsi(:) = 0
brvindx(:) = 0
bsdindx(:) = 0
counter = 1
idxs = 0
idxr = 0
do i=1,n
if (iprc(i) >=0) then
sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1
else
write(0,*)me,name,' Error from fnd_owner: ',iprc(i)
end if
end do
call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
& rvsz,1,psb_mpi_mpk_,icomm,minfo)
if (minfo /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall')
goto 9999
end if
!write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
nsnds = count(sdsz /= 0)
nrcvs = count(rvsz /= 0)
idxs = 0
idxr = 0
counter = 1
Do proc=0,np-1
bsdindx(proc+1) = idxs
idxs = idxs + sdsz(proc+1)
brvindx(proc+1) = idxr
idxr = idxr + rvsz(proc+1)
Enddo
iszs = sum(sdsz)
iszr = sum(rvsz)
call psb_realloc(iszs,lsnd,info)
if (info == 0) call psb_realloc(iszs,valsnd,info)
if (info == 0) call psb_realloc(iszr,x,info)
if (info == 0) call psb_realloc(iszr,ix,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='realloc')
goto 9999
end if
do k=1, n
proc = iprc(k)
sdsi(proc+1) = sdsi(proc+1) + 1
lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k)
valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k)
end do
do proc=0,np-1
if (sdsi(proc+1) /= sdsz(proc+1)) &
& write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
end do
select case(psb_get_sp_a2av_alg())
case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_)
call psb_simple_a2av(valsnd,sdsz,bsdindx,&
& x,rvsz,brvindx,ctxt,info)
if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,&
& ix,rvsz,brvindx,ctxt,info)
case(psb_sp_a2av_mpi_)
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,&
& x,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo)
if (minfo == mpi_success) &
& call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,&
& ix,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo /= mpi_success) info = minfo
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='wrong A2AV alg selector')
goto 9999
end select
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='alltoallv')
goto 9999
end if
Deallocate(brvindx,bsdindx,rvsz,sdsz,&
& lsnd,valsnd,stat=info)
if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
End Subroutine psb_c_remote_vect
base/tools/psb_callc.f90
+66 -3
View File
@@ -40,7 +40,7 @@
! x - the vector to be allocated.
! desc_a - the communication descriptor.
! info - Return code
subroutine psb_calloc_vect(x, desc_a,info)
subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
use psb_base_mod, psb_protect_name => psb_calloc_vect
use psi_mod
implicit none
@@ -49,9 +49,11 @@ subroutine psb_calloc_vect(x, desc_a,info)
type(psb_c_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act
integer(psb_ipk_) :: dupl_, bldmode_, nrmt_
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@@ -102,6 +104,25 @@ subroutine psb_calloc_vect(x, desc_a,info)
endif
call x%zero()
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if
call psb_erractionrestore(err_act)
return
@@ -110,6 +131,7 @@ subroutine psb_calloc_vect(x, desc_a,info)
return
end subroutine psb_calloc_vect
! Function: psb_calloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state.
@@ -121,7 +143,7 @@ end subroutine psb_calloc_vect
! n - optional number of columns.
! lb - optional lower bound on column indices
subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb, dupl, bldmode)
use psb_base_mod, psb_protect_name => psb_calloc_vect_r2
use psi_mod
implicit none
@@ -131,10 +153,12 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n,lb
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
!locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_
integer(psb_ipk_) :: dupl_, bldmode_, nrmt_
integer(psb_ipk_) :: exch(1)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@@ -208,6 +232,26 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
if (info /= 0) exit
end do
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
do i=lb_, lb_+n_-1
call x(i)%set_dupl(dupl_)
call x(i)%set_remote_build(bldmode_)
if (x(i)%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x(i)%rmtv(nrmt_))
end if
end do
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
@@ -224,7 +268,7 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
end subroutine psb_calloc_vect_r2
subroutine psb_calloc_multivect(x, desc_a,info,n)
subroutine psb_calloc_multivect(x, desc_a,info,n, dupl, bldmode)
use psb_base_mod, psb_protect_name => psb_calloc_multivect
use psi_mod
implicit none
@@ -234,10 +278,12 @@ subroutine psb_calloc_multivect(x, desc_a,info,n)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
!locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_
integer(psb_ipk_) :: dupl_, bldmode_, nrmt_
integer(psb_ipk_) :: exch(1)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@@ -306,6 +352,23 @@ subroutine psb_calloc_multivect(x, desc_a,info,n)
call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')
goto 9999
endif
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_)
if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_,n_))
end if
call psb_erractionrestore(err_act)
return
base/tools/psb_casb.f90
+23 -5
View File
@@ -64,7 +64,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
! local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -83,7 +83,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
dupl_ = x%get_dupl()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -104,6 +104,23 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%bld(ncol,mold=mold)
else
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
@@ -140,7 +157,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
! local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me, i, n
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, dupl_
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -159,7 +176,6 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ctxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
@@ -185,6 +201,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
else
do i=1, n
dupl_ = x(i)%get_dupl()
call x(i)%asb(ncol,info)
if (info /= 0) exit
! ..update halo elements..
@@ -225,7 +242,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n)
! local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_
integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_, dupl_
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
@@ -271,6 +288,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
dupl_ = x%get_dupl()
if (scratch_) then
call x%free(info)
call x%bld(ncol,n_,mold=mold)
base/tools/psb_cd_inloc.f90
+36 -32
View File
@@ -93,7 +93,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
nrt = loc_row
call psb_sum(ctxt,nrt)
call psb_max(ctxt,m)
if (present(globalcheck)) then
check_ = globalcheck
else
@@ -167,7 +167,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
if (check_.or.(.not.islarge)) then
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': Going for global checks'
allocate(tmpgidx(m,2),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
@@ -210,7 +210,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
info = psb_err_inconsistent_index_lists_
end if
end if
else
novrl = 0
norphan = 0
@@ -244,36 +244,40 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
call psb_errpush(info,name,l_err=l_err)
goto 9999
end if
! Sort, eliminate duplicates, then
! scramble back into original position.
ix(1) = -1
if (present(idx)) then
if (size(idx) >= loc_row) then
if (check_) then
! Sort, eliminate duplicates, then
! scramble back into original position.
ix(1) = -1
if (present(idx)) then
if (size(idx) >= loc_row) then
!$omp parallel do private(i)
do i=1, loc_row
ix(i) = idx(i)
end do
end if
end if
if (ix(1) == -1) then
!$omp parallel do private(i)
do i=1, loc_row
ix(i) = idx(i)
ix(i) = i
end do
end if
end if
if (ix(1) == -1) then
do i=1, loc_row
ix(i) = i
call psb_msort(vl,ix,flag=psb_sort_keep_idx_)
nlu = min(1,loc_row)
do i=2,loc_row
if (vl(i) /= vl(nlu)) then
nlu = nlu + 1
vl(nlu) = vl(i)
ix(nlu) = ix(i)
end if
end do
call psb_msort(ix(1:nlu),vl(1:nlu),flag=psb_sort_keep_idx_)
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': After sort ',nlu
else
nlu = loc_row
end if
call psb_msort(vl,ix,flag=psb_sort_keep_idx_)
nlu = min(1,loc_row)
do i=2,loc_row
if (vl(i) /= vl(nlu)) then
nlu = nlu + 1
vl(nlu) = vl(i)
ix(nlu) = ix(i)
end if
end do
call psb_msort(ix(1:nlu),vl(1:nlu),flag=psb_sort_keep_idx_)
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': After sort ',nlu
call psb_nullify_desc(desc)
if (do_timings) then
call psb_barrier(ctxt)
@@ -289,7 +293,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
if (novrl > 0) then
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': Check overlap '
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': code for NOVRL>0',novrl,npr_ov
@@ -335,7 +339,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
end if
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': Done overlap '
! allocate work vector
allocate(l_temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),&
@@ -393,7 +397,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
end if
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': Allocate indxmap'
if (np == 1) then
allocate(psb_repl_map :: desc%indxmap, stat=info)
else
@@ -414,7 +418,7 @@ subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash)
if (debug_size) &
& write(debug_unit,*) me,' ',trim(name),': Done init indxmap'
if (do_timings) then
call psb_barrier(ctxt)
t4 = psb_wtime()
base/tools/psb_cdall.f90
+49 -3
View File
@@ -1,3 +1,39 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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_cdall.f90
!
! Subroutine: psb_cdall
! Allocate descriptor Outer routine
!
subroutine psb_cdall(ctxt, desc, info,mg,ng,parts,&
& vg,vl,flag,nl,repl,globalcheck,lidx,usehash)
use psb_desc_mod
@@ -62,14 +98,15 @@ subroutine psb_cdall(ctxt, desc, info,mg,ng,parts,&
logical :: usehash_
integer(psb_ipk_), allocatable :: itmpv(:)
integer(psb_lpk_), allocatable :: lvl(:)
logical, parameter :: timings=.false.
real(psb_dpk_) :: t0, t1
if (psb_get_errstatus() /= 0) return
info=psb_success_
name = 'psb_cdall'
call psb_erractionsave(err_act)
if (timings) t0 = psb_wtime()
call psb_info(ctxt, me, np)
if (count((/ present(vg),present(vl),&
& present(parts),present(nl), present(repl) /)) < 1) then
@@ -189,7 +226,11 @@ subroutine psb_cdall(ctxt, desc, info,mg,ng,parts,&
endif
if (info /= psb_success_) goto 9999
if (timings) then
t1 = psb_wtime()
write(0,*) name,' 1st phase:',t1-t0
t0 = psb_wtime()
end if
! Finish off
lr = desc%indxmap%get_lr()
call psb_realloc(max(1,lr/2),desc%halo_index, info)
@@ -203,6 +244,11 @@ subroutine psb_cdall(ctxt, desc, info,mg,ng,parts,&
desc%ext_index(:) = -1
call psb_cd_set_bld(desc,info)
if (info /= psb_success_) goto 9999
if (timings) then
t1 = psb_wtime()
write(0,*) name,' 2nd phase:',t1-t0
t0 = psb_wtime()
end if
9998 continue
call psb_erractionrestore(err_act)
base/tools/psb_cdalv.f90
+2 -1
View File
@@ -151,6 +151,7 @@ subroutine psb_cdalv(v, ctxt, desc, info, flag)
itmpov = 0
temp_ovrlap(:) = -1
!$omp parallel do private(i) reduction(+:counter)
do i=1,m
if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then
@@ -158,7 +159,7 @@ subroutine psb_cdalv(v, ctxt, desc, info, flag)
l_err(1)=3
l_err(2)=v(i) - flag_
l_err(3)=i
exit
!exit
end if
if ((v(i)-flag_) == me) then
base/tools/psb_cins.f90
+36 -46
View File
@@ -42,10 +42,7 @@
! x - type(psb_c_vect_type) The destination vector
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
use psb_base_mod, psb_protect_name => psb_cins_vect
use psi_mod
implicit none
@@ -57,14 +54,14 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_,err_act
integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
@@ -112,7 +109,6 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
@@ -120,11 +116,6 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
@@ -136,11 +127,33 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,dupl_,info)
call x%ins(m,irl,val,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl)
call psb_erractionrestore(err_act)
@@ -166,10 +179,7 @@ end subroutine psb_cins_vect
! x - type(psb_c_vect_type) The destination vector
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
use psb_base_mod, psb_protect_name => psb_cins_vect_v
use psi_mod
implicit none
@@ -185,14 +195,13 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:)
complex(psb_spk_), allocatable :: lval(:)
logical :: local_
@@ -239,14 +248,6 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
@@ -260,7 +261,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,lval,dupl_,info)
call x%ins(m,irl,lval,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
@@ -275,7 +276,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
end subroutine psb_cins_vect_v
subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local)
use psb_base_mod, psb_protect_name => psb_cins_vect_r2
use psi_mod
implicit none
@@ -291,14 +292,13 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
type(psb_c_vect_type), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act
integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
@@ -353,11 +353,6 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
@@ -371,8 +366,9 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info /= 0) exit
end do
if (info /= 0) then
@@ -390,7 +386,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
end subroutine psb_cins_vect_r2
subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local)
subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local)
use psb_base_mod, psb_protect_name => psb_cins_multivect
use psi_mod
implicit none
@@ -406,14 +402,13 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local)
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act
integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
@@ -469,11 +464,6 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
@@ -485,7 +475,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,dupl_,info)
call x%ins(m,irl,val,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
base/tools/psb_cspalloc.f90
+27 -7
View File
@@ -41,21 +41,23 @@
! nnz - integer(optional). The number of nonzeroes in the matrix.
! (local, user estimate)
!
subroutine psb_cspalloc(a, desc_a, info, nnz)
subroutine psb_cspalloc(a, desc_a, info, nnz, dupl, bldmode)
use psb_base_mod, psb_protect_name => psb_cspalloc
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: nnz
integer(psb_ipk_), optional, intent(in) :: dupl, bldmode
!locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype
integer(psb_lpk_) :: m, n
integer(psb_ipk_) :: dupl_, bldmode_
integer(psb_lpk_) :: m, n, nnzrmt_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@@ -96,7 +98,7 @@ subroutine psb_cspalloc(a, desc_a, info, nnz)
else
nnz_ = max(1,5*loc_row)
endif
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name), &
& ':allocating size:',loc_row,loc_col,nnz_
@@ -109,6 +111,24 @@ subroutine psb_cspalloc(a, desc_a, info, nnz)
goto 9999
end if
if (present(bldmode)) then
bldmode_ = bldmode
else
bldmode_ = psb_matbld_noremote_
end if
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_def_
end if
call a%set_dupl(dupl_)
call a%set_remote_build(bldmode_)
if (a%is_remote_build()) then
allocate(a%rmta)
nnzrmt_ = max(100,(nnz_/100))
call a%rmta%allocate(m,n,nnzrmt_)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': ', &
& desc_a%get_dectype(),psb_desc_bld_

Some files were not shown because too many files have changed in this diff Show More