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

merge with unify_agg_build

Browse Source
This commit is contained in:
Cirdans-Home
2020-04-25 15:25:18 +02:00
parent 9870e5d371 84a8b73416
commit c0ccbe14f7
194 changed files with 27944 additions and 8867 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Changelog
+16
View File
@@ -1,5 +1,21 @@
Changelog. A lot less detailed than usual, at least for past
history.
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
2019/07/08: Fix memory usage in conversions to/from coo
2019/07/01: Timer facility
2019/06/25: Fix memory footprint in spspmm and other borderline cases
2019/06/17: Make ADD default assembly action.
2019/05/30: new insertion routines in CSR mode
2019/05/27: Fix matrix generation.
2019/05/26: New timer facility (undocumented).
2019/05/20: Change checks on vectors
2019/05/05: Reworked linmap internals
2019/04/15: Improved sphalo and test programs printout
2019/04/09: bump version to 3.6.1
2019/04/09: new fnd_owner_halo method
2019/03/31: New RENUM_BLK descriptor method
2019/01/16: In bldext, implement ALL_TO_ALLV by hand for certain
compilers.
2018/10/10: New ICTXT argument in prec%init
Makefile
+10 -10
View File
@@ -15,15 +15,15 @@ libd:
(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:
cd base && $(MAKE) lib
$(MAKE) -C base lib
precd:
cd prec && $(MAKE) lib
$(MAKE) -C prec lib
kryld:
cd krylov && $(MAKE) lib
$(MAKE) -C krylov lib
utild:
cd util&& $(MAKE) lib
$(MAKE) -C util lib
cbindd:
cd cbind&& $(MAKE) lib
$(MAKE) -C cbind lib
install: all
mkdir -p $(INSTALL_INCLUDEDIR) &&\
@@ -42,11 +42,11 @@ install: all
/bin/cp -fr test/pargen test/fileread test/kernel $(INSTALL_SAMPLESDIR) && \
mkdir -p $(INSTALL_SAMPLESDIR)/cbind && /bin/cp -fr cbind/test/pargen/* $(INSTALL_SAMPLESDIR)/cbind
clean:
cd base && $(MAKE) clean
cd prec && $(MAKE) clean
cd krylov && $(MAKE) clean
cd util && $(MAKE) clean
cd cbind && $(MAKE) clean
$(MAKE) -C base clean
$(MAKE) -C prec clean
$(MAKE) -C krylov clean
$(MAKE) -C util clean
$(MAKE) -C cbind clean
check: all
make check -C test/serial
base/Makefile
+12 -12
View File
@@ -13,25 +13,25 @@ lib: mods sr cm in pb tl
sr cm in pb tl: mods
mods:
cd modules && $(MAKE) lib LIBNAME=$(BASELIBNAME) F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
$(MAKE) -C modules lib LIBNAME=$(BASELIBNAME) F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
sr:
cd serial && $(MAKE) lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C serial lib LIBNAME=$(BASELIBNAME)
cm:
cd comm && $(MAKE) lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C comm lib LIBNAME=$(BASELIBNAME)
in:
cd internals && $(MAKE) lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C internals lib LIBNAME=$(BASELIBNAME)
pb:
cd psblas && $(MAKE) lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C psblas lib LIBNAME=$(BASELIBNAME)
tl:
cd tools && $(MAKE) lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C tools lib LIBNAME=$(BASELIBNAME)
clean:
(cd modules; $(MAKE) clean)
(cd comm; $(MAKE) clean)
(cd internals; $(MAKE) clean)
(cd tools; $(MAKE) clean)
(cd serial; $(MAKE) clean)
(cd psblas; $(MAKE) clean)
($(MAKE) -C modules clean)
($(MAKE) -C comm clean)
($(MAKE) -C internals clean)
($(MAKE) -C tools clean)
($(MAKE) -C serial clean)
($(MAKE) -C psblas clean)
veryclean: clean
/bin/rm -f $(HERE)/$(LIBNAME) $(LIBMOD) *$(.mod)
base/comm/Makefile
+1 -1
View File
@@ -32,7 +32,7 @@ lib: interns mpfobjs $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
interns:
cd internals && $(MAKE) lib
$(MAKE) -C internals lib
mpfobjs:
$(MAKE) $(MPFOBJS) FC="$(MPFC)"
base/comm/internals/psi_i2ovrl_restr_a.f90
+129
View File
@@ -0,0 +1,129 @@
!
! 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.
!
!
! Subroutine: psi_i2ovrl_restr
! These subroutines restore the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_restrr1
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2ovrl_restrr1
subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_restrr2
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2ovrl_restrr2
base/comm/internals/psi_i2ovrl_save_a.f90
+139
View File
@@ -0,0 +1,139 @@
!
! 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.
!
!
!
! Subroutine: psi_i2ovrl_save
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_saver1
use psb_realloc_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2ovrl_saver1
subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_saver2
use psb_realloc_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2ovrl_saver2
base/comm/internals/psi_i2ovrl_upd_a.f90
+173
View File
@@ -0,0 +1,173 @@
!
! 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.
!
!
! Subroutine: psi_i2ovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_i2ovrl_updr1
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2ovrl_updr1
subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_i2ovrl_updr2
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2ovrl_updr2
base/comm/internals/psi_i2swapdata_a.F90
+990
View File
@@ -0,0 +1,990 @@
!
! 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: psi_i2swapdata.F90
!
! Subroutine: psi_i2swapdatam
! Implements the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in our
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! S real(psb_spk_)
! D real(psb_dpk_)
! C complex(psb_spk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1.
! The first routine picks the desired exchange index list and passes it to the second.
!
! Arguments:
! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send
! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
!
! n - integer Number of columns in Y
! beta - integer Choose overwrite or sum.
! y(:,:) - integer The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - integer Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_i2swapdatam
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag, n
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:,:), beta
integer(psb_i2pk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
character(len=20) :: name
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info=psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if(present(data)) then
data_ = data
else
data_ = psb_comm_halo_
end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2swapdatam
subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_i2swapidxm
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:,:), beta
integer(psb_i2pk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpk_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
totrcv_ = totrcv * n
totsnd_ = totsnd * n
if (swap_mpi) then
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
rvhd(:) = mpi_request_null
sdsz(:) = 0
rvsz(:) = 0
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
bsdidx(proc_to_comm) = snd_pt
sdsz(proc_to_comm) = n*nesd
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
sndbuf => work(1:totsnd_)
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
end if
if (do_send) then
! Pack send buffers
pnti = 1
snd_pt = 1
do i=1, totxch
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+n*nesd-1))
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
end if
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_i2pk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_i2pk_,icomm,iret)
if(iret /= mpi_success) then
info=psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
end if
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int2_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_i2pk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int2_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_i2pk_,prcid(i),&
& p2ptag,icomm,iret)
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_i2pk_,prcid(i),&
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
info=psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
end if
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int2_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
info=psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*)&
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_i2swapidxm
!
!
! Subroutine: psi_i2swapdatav
! Implements the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! S real(psb_spk_)
! D real(psb_dpk_)
! C complex(psb_spk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
! but only on the elements involved in the UNPACK operation.
! Thus: for halo data exchange, the receive section is confined in the
! halo indices, and BETA=0, whereas for overlap exchange the receive section
! is scattered in the owned indices, and BETA=1.
! The first routine picks the desired exchange index list and passes it to the second.
!
! Arguments:
! flag - integer Choose the algorithm for data exchange:
! this is chosen through bit fields.
! swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! swap_sync = iand(flag,psb_swap_sync_) /= 0
! swap_send = iand(flag,psb_swap_send_) /= 0
! swap_recv = iand(flag,psb_swap_recv_) /= 0
! if (swap_mpi): use underlying MPI_ALLTOALLV.
! if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs
! if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send
! if (swap_send): use psb_snd (but need another
! call with swap_recv to complete)
! if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
!
! n - integer Number of columns in Y
! beta - integer Choose overwrite or sum.
! y(:) - integer The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - integer Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
! psb_comm_halo_ use halo_index
! psb_comm_ext_ use ext_index
! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_i2swapdatav
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
integer(psb_i2pk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info=psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i2swapdatav
!
!
! Subroutine: psi_i2swapdataidxv
! Does the data exchange among processes.
!
! The real workhorse: the outer routines will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
!
subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_i2swapidxv
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
integer(psb_i2pk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpk_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
totrcv_ = totrcv * n
totsnd_ = totsnd * n
if (swap_mpi) then
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
rvhd(:) = mpi_request_null
sdsz(:) = 0
rvsz(:) = 0
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
bsdidx(proc_to_comm) = snd_pt
sdsz(proc_to_comm) = nesd
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
sndbuf => work(1:totsnd_)
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
end if
if (do_send) then
! Pack send buffers
pnti = 1
snd_pt = 1
do i=1, totxch
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1))
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_i2pk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_i2pk_,icomm,iret)
if(iret /= mpi_success) then
info=psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
end if
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int2_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_i2pk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int2_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_i2pk_,prcid(i),&
& p2ptag,icomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_i2pk_,prcid(i),&
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
info=psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int2_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
info=psb_err_mpi_error_
call psb_errpush(info,name,m_err=(/iret/))
goto 9999
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_i2swapidxv
base/comm/internals/psi_i2swaptran_a.F90
+1006
View File
File diff suppressed because it is too large Load Diff
base/comm/psb_cspgather.F90
+142 -63
View File
@@ -70,7 +70,7 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: ierr(5)
@@ -98,7 +98,12 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -137,27 +142,48 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call psb_errpush(info,name); goto 9999
end if
#endif
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call psb_realloc(ione,glbia,info)
if (info == psb_success_) call psb_realloc(ione,glbja,info)
if (info == psb_success_) call glob_coo%allocate(ione,ione,ione)
end if
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
@@ -172,11 +198,13 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
deallocate(glbia,glbja, stat=info)
else
@@ -228,7 +256,7 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -256,7 +284,13 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -269,7 +303,7 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
goto 9999
end if
if (keeploc_) then
call loca%cp_to(loc_coo)
else
@@ -294,7 +328,11 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
!
! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING
@@ -303,24 +341,37 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
call loc_coo%free()
!
! Is the code below safe? For very large cases
@@ -328,9 +379,11 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
@@ -346,7 +399,7 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_lcsp_allgather
subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
@@ -378,7 +431,7 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -406,7 +459,13 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -444,25 +503,43 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
@@ -470,9 +547,11 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
end if
call loc_coo%free()
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
base/comm/psb_dspgather.F90
+142 -63
View File
@@ -70,7 +70,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: ierr(5)
@@ -98,7 +98,12 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -137,27 +142,48 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call psb_errpush(info,name); goto 9999
end if
#endif
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call psb_realloc(ione,glbia,info)
if (info == psb_success_) call psb_realloc(ione,glbja,info)
if (info == psb_success_) call glob_coo%allocate(ione,ione,ione)
end if
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
@@ -172,11 +198,13 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
deallocate(glbia,glbja, stat=info)
else
@@ -228,7 +256,7 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -256,7 +284,13 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -269,7 +303,7 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
goto 9999
end if
if (keeploc_) then
call loca%cp_to(loc_coo)
else
@@ -294,7 +328,11 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
!
! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING
@@ -303,24 +341,37 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
call loc_coo%free()
!
! Is the code below safe? For very large cases
@@ -328,9 +379,11 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
@@ -346,7 +399,7 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_ldsp_allgather
subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
@@ -378,7 +431,7 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -406,7 +459,13 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -444,25 +503,43 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
@@ -470,9 +547,11 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
end if
call loc_coo%free()
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
base/comm/psb_i2gather_a.f90
+335
View File
@@ -0,0 +1,335 @@
!
! 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_i2gather.f90
!
! Subroutine: psb_i2gather
! This subroutine gathers pieces of a distributed dense matrix into a local one.
!
! Arguments:
! globx - integer,dimension(:,:). The local matrix into which gather
! the distributed pieces.
! locx - integer,dimension(:,:). The local piece of the distributed
! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
!
subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_i2gatherm
implicit none
integer(psb_i2pk_), intent(in) :: locx(:,:)
integer(psb_i2pk_), intent(out), allocatable :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
name='psb_i2gatherm'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
end if
if (root == -1) then
iiroot = psb_root_
else
iiroot = root
endif
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lda_globx = m
lda_locx = size(locx, 1)
lock = size(locx,2)
maxk = lock
k = maxk
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) &
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
call psb_realloc(m,k,globx,info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
globx(:,:)=i2zero
do j=1,k
do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx,j) = locx(i,jlx+j-1)
end do
end do
do j=1,k
! adjust overlapped elements
do i=1, size(desc_a%ovrlap_elem,1)
if (me /= desc_a%ovrlap_elem(i,3)) then
idx = desc_a%ovrlap_elem(i,1)
call psb_loc_to_glob(idx,desc_a,info)
globx(idx,j) = i2zero
end if
end do
end do
call psb_sum(ictxt,globx(1:m,1:k),root=root)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2gatherm
!!$
!!$ Parallel Sparse BLAS version 3.5
!!$ (C) Copyright 2006-2018
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ 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.
!!$
!!$
! Subroutine: psb_i2gatherv
! This subroutine gathers pieces of a distributed dense vector into a local one.
!
! Arguments:
! globx - integer,dimension(:). The local vector into which gather
! the distributed pieces.
! locx - integer,dimension(:). The local piece of the distributed
! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! default: -1
!
subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_i2gatherv
implicit none
integer(psb_i2pk_), intent(in) :: locx(:)
integer(psb_i2pk_), intent(out), allocatable :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
name='psb_i2gatherv'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
end if
jglobx=1
iglobx = 1
jlocx=1
ilocx = 1
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lda_globx = m
lda_locx = size(locx)
k = 1
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) &
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
call psb_realloc(m,globx,info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
globx(:)=i2zero
do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = locx(i)
end do
! adjust overlapped elements
do i=1, size(desc_a%ovrlap_elem,1)
if (me /= desc_a%ovrlap_elem(i,3)) then
idx = desc_a%ovrlap_elem(i,1)
call psb_loc_to_glob(idx,desc_a,info)
globx(idx) = i2zero
end if
end do
call psb_sum(ictxt,globx(1:m),root=root)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2gatherv
base/comm/psb_i2halo_a.f90
+380
View File
@@ -0,0 +1,380 @@
!
! 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_i2halo.f90
!
! Subroutine: psb_i2halom
! This subroutine performs the exchange of the halo elements in a
! distributed dense matrix between all the processes.
!
! Arguments:
! x - integer,dimension(:,:). The local part of the dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! 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_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_i2halom
use psi_mod
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_i2pk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_i2halom'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
ix = 1
if (present(jx)) then
ijx = jx
else
ijx = 1
endif
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
maxk=size(x,2)-ijx+1
if(present(ik)) then
if(ik > maxk) then
k=maxk
else
k=ik
end if
else
k = maxk
end if
if (present(tran)) then
tran_ = psb_toupper(tran)
else
tran_ = 'N'
endif
if (present(mode)) then
imode = mode
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
endif
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.)
if(info /= psb_success_) then
info=psb_err_from_subroutine_ ; ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
iwork => work
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
xp => x(iix:size(x,1),jjx:jjx+k-1)
if(tran_ == 'N') then
call psi_swapdata(imode,k,i2zero,xp,&
& desc_a,iwork,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,k,i2one,xp,&
&desc_a,iwork,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= psb_success_) then
ch_err='PSI_cswapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2halom
!!$
!!$ Parallel Sparse BLAS version 3.5
!!$ (C) Copyright 2006-2018
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ 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.
!!$
!!$
!
! Subroutine: psb_i2halov
! This subroutine performs the exchange of the halo elements in a
! distributed dense vector between all the processes.
!
! Arguments:
! x - real,dimension(:). The local part of the dense vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! 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_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_i2halov
use psi_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_i2pk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_i2halov'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
ix = 1
ijx = 1
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
if (present(tran)) then
tran_ = psb_toupper(tran)
else
tran_ = 'N'
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
endif
if (present(mode)) then
imode = mode
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.)
if(info /= psb_success_) then
info=psb_err_from_subroutine_ ; ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
iwork => work
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,i2zero,x(iix:size(x)),&
& desc_a,iwork,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,i2one,x(iix:size(x)),&
& desc_a,iwork,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= psb_success_) then
ch_err='PSI_swapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2halov
base/comm/psb_i2ovrl_a.f90
+374
View File
@@ -0,0 +1,374 @@
!
! 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_i2ovrl.f90
!
! Subroutine: psb_i2ovrlm
! This subroutine performs the exchange of the overlap elements in a
! distributed dense matrix between all the processes.
!
! Arguments:
! x(:,:) - integer The local part of the dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
! psb_avg_ average of overlaps
! mode - integer(optional). Choose the algorithm for data exchange:
! this is chosen through bit fields.
! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! - swap_sync = iand(flag,psb_swap_sync_) /= 0
! - swap_send = iand(flag,psb_swap_send_) /= 0
! - swap_recv = iand(flag,psb_swap_recv_) /= 0
! - if (swap_mpi): use underlying MPI_ALLTOALLV.
! - if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs
! - if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send
! - if (swap_send): use psb_snd (but need another
! call with swap_recv to complete)
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
!
subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode)
use psb_base_mod, psb_protect_name => psb_i2ovrlm
use psi_mod
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_i2pk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_i2ovrlm'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
ix = 1
if (present(jx)) then
ijx = jx
else
ijx = 1
endif
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
maxk=size(x,2)-ijx+1
if(present(ik)) then
if(ik > maxk) then
k=maxk
else
k=ik
end if
else
k = maxk
end if
if (present(update)) then
update_ = update
else
update_ = psb_avg_
endif
if (present(mode)) then
mode_ = mode
else
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_ ; ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if(do_swap) then
xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,i2one,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2ovrlm
!!$
!!$ Parallel Sparse BLAS version 3.5
!!$ (C) Copyright 2006-2018
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ 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.
!!$
!!$
!
! Subroutine: psb_i2ovrlv
! This subroutine performs the exchange of the overlap elements in a
! distributed dense vector between all the processes.
!
! Arguments:
! x(:) - integer The local part of the dense vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
! psb_avg_ average of overlaps
! mode - integer(optional). Choose the algorithm for data exchange:
! this is chosen through bit fields.
! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! - swap_sync = iand(flag,psb_swap_sync_) /= 0
! - swap_send = iand(flag,psb_swap_send_) /= 0
! - swap_recv = iand(flag,psb_swap_recv_) /= 0
! - if (swap_mpi): use underlying MPI_ALLTOALLV.
! - if (swap_sync): use PSB_SND and PSB_RCV in
! synchronized pairs
! - if (swap_send .and. swap_recv): use mpi_irecv
! and mpi_send
! - if (swap_send): use psb_snd (but need another
! call with swap_recv to complete)
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
!
subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode)
use psb_base_mod, psb_protect_name => psb_i2ovrlv
use psi_mod
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_i2pk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_i2ovrlv'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
ix = 1
ijx = 1
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
k = 1
if (present(update)) then
update_ = update
else
update_ = psb_avg_
endif
if (present(mode)) then
mode_ = mode
else
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
if(info /= 0) goto 9999
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,i2one,x,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2ovrlv
base/comm/psb_i2scatter_a.F90
+480
View File
@@ -0,0 +1,480 @@
!
! 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_i2scatter.f90
!
! Subroutine: psb_i2scatterm
! This subroutine scatters a global matrix locally owned by one process
! into pieces that are local to all the processes.
!
! Arguments:
! globx - integer,dimension(:,:). The global matrix to scatter.
! locx - integer,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_i2scatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_i2scatterm
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_i2pk_), intent(out), allocatable :: locx(:,:)
integer(psb_i2pk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr
integer(psb_ipk_) :: ierr(5), err_act, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx
integer(psb_i2pk_),allocatable :: scatterv(:)
integer(psb_mpk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err
name='psb_scatterm'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
iroot = psb_root_
end if
iglobx = 1
jglobx = 1
lda_globx = size(globx,1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
icomm = psb_get_mpi_comm(ictxt)
myrank = psb_get_mpi_rank(ictxt,me)
if (iroot==-1) then
lda_globx = size(globx, 1)
k = size(globx,2)
else
if (iam==iroot) then
k = size(globx,2)
lda_globx = size(globx, 1)
end if
end if
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
! there should be a global check on k here!!!
if ((iroot==-1).or.(iam==iroot)) &
& call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nrow=desc_a%get_local_rows()
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info,n=k)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
locx(i,j)=globx(ltg(i),j)
end do
end do
else
rootrank = psb_get_mpi_rank(ictxt,iroot)
!
! This is potentially unsafe when IPK=8
! But then, IPK=8 is highly experimental anyway.
!
nlr = nrow
call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,&
& 1,psb_mpi_mpk_,rootrank,icomm,info)
if (iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1)+all_dim(i-1)
end do
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nlr,&
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
if(iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx,col)
end do
end do
end if
! scatter
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_i2pk_,locx(1,col),nrow,&
& psb_mpi_i2pk_,rootrank,icomm,info)
end do
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2scatterm
!!$
!!$ Parallel Sparse BLAS version 3.5
!!$ (C) Copyright 2006-2018
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ 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.
!!$
!!$
! Subroutine: psb_i2scatterv
! This subroutine scatters a global vector locally owned by one process
! into pieces that are local to all the processes.
!
! Arguments:
! globx - integer,dimension(:). The global vector to scatter.
! locx - integer,dimension(:). The local piece of the ditributed vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy.
!
subroutine psb_i2scatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_i2scatterv
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_i2pk_), intent(out), allocatable :: locx(:)
integer(psb_i2pk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr
integer(psb_ipk_) :: ierr(5), err_act, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx
integer(psb_i2pk_), allocatable :: scatterv(:)
integer(psb_mpk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit
name='psb_scatterv'
info=psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ictxt=desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
! check on blacs grid
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
iroot = psb_root_
end if
icomm = psb_get_mpi_comm(ictxt)
myrank = psb_get_mpi_rank(ictxt,iam)
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
if ((iroot==-1).or.(iam==iroot))&
& lda_globx = size(globx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
k = 1
! there should be a global check on k here!!!
if ((iroot==-1).or.(iam==iroot)) &
& call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nrow = desc_a%get_local_rows()
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
locx(i)=globx(ltg(i))
end do
else
rootrank = psb_get_mpi_rank(ictxt,iroot)
!
! This is potentially unsafe when IPK=8
! But then, IPK=8 is highly experimental anyway.
!
nlr = nrow
call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,&
& 1,psb_mpi_mpk_,rootrank,icomm,info)
if(iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1) + all_dim(i-1)
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nlr,&
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
if (iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx)
end do
end do
end if
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_i2pk_,locx,nrow,&
& psb_mpi_i2pk_,rootrank,icomm,info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_i2scatterv
base/comm/psb_ispgather.F90
+142 -63
View File
@@ -70,7 +70,7 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: ierr(5)
@@ -98,7 +98,12 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -137,27 +142,48 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call psb_errpush(info,name); goto 9999
end if
#endif
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call psb_realloc(ione,glbia,info)
if (info == psb_success_) call psb_realloc(ione,glbja,info)
if (info == psb_success_) call glob_coo%allocate(ione,ione,ione)
end if
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
@@ -172,11 +198,13 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
deallocate(glbia,glbja, stat=info)
else
@@ -228,7 +256,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -256,7 +284,13 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -269,7 +303,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
goto 9999
end if
if (keeploc_) then
call loca%cp_to(loc_coo)
else
@@ -294,7 +328,11 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
!
! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING
@@ -303,24 +341,37 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
call loc_coo%free()
!
! Is the code below safe? For very large cases
@@ -328,9 +379,11 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
@@ -346,7 +399,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_@LX@sp_allgather
subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
@@ -378,7 +431,7 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -406,7 +459,13 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -444,25 +503,43 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_ipk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
@@ -470,9 +547,11 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
end if
call loc_coo%free()
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
base/comm/psb_lspgather.F90
+142 -63
View File
@@ -70,7 +70,7 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: ierr(5)
@@ -98,7 +98,12 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -137,27 +142,48 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call psb_errpush(info,name); goto 9999
end if
#endif
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call psb_realloc(ione,glbia,info)
if (info == psb_success_) call psb_realloc(ione,glbja,info)
if (info == psb_success_) call glob_coo%allocate(ione,ione,ione)
end if
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
@@ -172,11 +198,13 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
deallocate(glbia,glbja, stat=info)
else
@@ -228,7 +256,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -256,7 +284,13 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -269,7 +303,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
goto 9999
end if
if (keeploc_) then
call loca%cp_to(loc_coo)
else
@@ -294,7 +328,11 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
!
! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING
@@ -303,24 +341,37 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
call loc_coo%free()
!
! Is the code below safe? For very large cases
@@ -328,9 +379,11 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
@@ -346,7 +399,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_@LX@sp_allgather
subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
@@ -378,7 +431,7 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -406,7 +459,13 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -444,25 +503,43 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_lpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
@@ -470,9 +547,11 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn
end if
call loc_coo%free()
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
base/comm/psb_sspgather.F90
+142 -63
View File
@@ -70,7 +70,7 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: ierr(5)
@@ -98,7 +98,12 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -137,27 +142,48 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call psb_errpush(info,name); goto 9999
end if
#endif
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call psb_realloc(ione,glbia,info)
if (info == psb_success_) call psb_realloc(ione,glbja,info)
if (info == psb_success_) call glob_coo%allocate(ione,ione,ione)
end if
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
@@ -172,11 +198,13 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
deallocate(glbia,glbja, stat=info)
else
@@ -228,7 +256,7 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -256,7 +284,13 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -269,7 +303,7 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
goto 9999
end if
if (keeploc_) then
call loca%cp_to(loc_coo)
else
@@ -294,7 +328,11 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
!
! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING
@@ -303,24 +341,37 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
call loc_coo%free()
!
! Is the code below safe? For very large cases
@@ -328,9 +379,11 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
@@ -346,7 +399,7 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_lssp_allgather
subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
@@ -378,7 +431,7 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -406,7 +459,13 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -444,25 +503,43 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_r_spk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
@@ -470,9 +547,11 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
end if
call loc_coo%free()
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
base/comm/psb_zspgather.F90
+142 -63
View File
@@ -70,7 +70,7 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: ierr(5)
@@ -98,7 +98,12 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -137,27 +142,48 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call psb_errpush(info,name); goto 9999
end if
#endif
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call psb_realloc(ione,glbia,info)
if (info == psb_success_) call psb_realloc(ione,glbja,info)
if (info == psb_success_) call glob_coo%allocate(ione,ione,ione)
end if
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
@@ -172,11 +198,13 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
deallocate(glbia,glbja, stat=info)
else
@@ -228,7 +256,7 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -256,7 +284,13 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -269,7 +303,7 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
goto 9999
end if
if (keeploc_) then
call loca%cp_to(loc_coo)
else
@@ -294,7 +328,11 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
!
! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING
@@ -303,24 +341,37 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
call loc_coo%free()
!
! Is the code below safe? For very large cases
@@ -328,9 +379,11 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
@@ -346,7 +399,7 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee
call psb_error_handler(ione*ictxt,err_act)
return
end subroutine psb_lzsp_allgather
subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
@@ -378,7 +431,7 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_
integer(psb_mpk_) :: ictxt,np,me
integer(psb_mpk_) :: icomm, minfo, ndx
integer(psb_mpk_) :: icomm, minfo, ndx, root_
integer(psb_mpk_), allocatable :: nzbr(:), idisp(:)
integer(psb_lpk_), allocatable :: lnzbr(:)
integer(psb_ipk_) :: ierr(5)
@@ -406,7 +459,13 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
else
keeploc_ = .true.
end if
call globa%free()
if (present(root)) then
root_ = root
else
root_ = -1
end if
if ((root_ == -1).or.(root_ == me)) call globa%free()
if (keepnum_) then
nrg = desc_a%get_global_rows()
@@ -444,25 +503,43 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
call psb_errpush(info,name); goto 9999
end if
#endif
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if ((root_ == -1).or.(root_ == me)) then
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
else
if (info == psb_success_) call glob_coo%allocate(1_psb_lpk_,1_psb_lpk_,1_psb_lpk_)
end if
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
ndx = nzbr(me+1)
if (root_ == -1) then
call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
else
call mpi_gatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,&
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_gatherv(loc_coo%ja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_lpk_,root_,icomm,minfo)
end if
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
@@ -470,9 +547,11 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k
end if
call loc_coo%free()
!
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
if ((root_ == -1).or.(root_ == me)) then
call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
end if
else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_
base/internals/psi_a2a_fnd_owner.F90
+100 -13
View File
@@ -47,7 +47,7 @@
! so it goes for an all-to-all by building an auxiliary neighbours list and
! reusing the neighbour version.
!
subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info)
subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize)
use psb_serial_mod
use psb_const_mod
use psb_error_mod
@@ -66,15 +66,22 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: samesize
integer(psb_ipk_), allocatable :: tmpadj(:)
integer(psb_mpk_) :: icomm, minfo, iictxt
integer(psb_ipk_) :: i,n_row,n_col,err_act,nv
integer(psb_lpk_), allocatable :: rmtidx(:)
integer(psb_ipk_), allocatable :: tproc(:), lclidx(:)
integer(psb_mpk_), allocatable :: hsz(:),hidx(:), sdidx(:), rvidx(:),&
& sdsz(:), rvsz(:), sdhd(:), rvhd(:), p2pstat(:,:)
integer(psb_mpk_) :: icomm, minfo, iictxt,nv
integer(psb_ipk_) :: i,n_row,n_col,err_act,gsz
integer(psb_lpk_) :: mglob, ih
integer(psb_ipk_) :: ictxt,np,me, nresp
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
character(len=20) :: name
logical, parameter :: use_psi_adj=.true.
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
character(len=20) :: name
logical :: samesize_
info = psb_success_
name = 'psi_a2a_fnd_owner'
@@ -100,15 +107,95 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info)
goto 9999
end if
!
! Reuse the adjcncy version by tricking it with an adjcncy list
! that contains everybody but ME.
!
if (present(samesize)) then
samesize_ = samesize
else
samesize_ = .false.
end if
nv = size(idx)
call psb_realloc(np-1,tmpadj,info)
tmpadj(1:me) = [(i,i=0,me-1)]
tmpadj(me+1:np-1) = [(i,i=me+1,np-1)]
call psi_adjcncy_fnd_owner(idx,iprc,tmpadj,idxmap,info)
! write(0,*) me,name,' :',use_psi_adj,samesize_,nv
if (use_psi_adj) then
!
! Reuse the adjcncy version by tricking it with an adjcncy list
! that contains everybody but ME.
!
call psb_realloc(np-1,tmpadj,info)
tmpadj(1:me) = [(i,i=0,me-1)]
tmpadj(me+1:np-1) = [(i,i=me+1,np-1)]
call psi_adjcncy_fnd_owner(idx,iprc,tmpadj,idxmap,info)
else
if (samesize_) then
!
! Variant when IDX is guaranteed to have the same size on all
! processes. To be tested for performance: is it worth it?
! Probably yes.
!
gsz = nv*np
Allocate(rmtidx(gsz),lclidx(gsz),iprc(nv),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call mpi_allgather(idx,nv,psb_mpi_lpk_,rmtidx,nv,psb_mpi_lpk_,icomm,minfo)
call idxmap%g2l(rmtidx(1:gsz),lclidx(1:gsz),info,owned=.true.)
!
! Reuse lclidx to encode owning process
!
do i=1, gsz
if ((1<=lclidx(i)).and.(lclidx(i)<=n_row)) then
lclidx(i) = me
else
lclidx(i) = -1
end if
end do
call mpi_reduce_scatter_block(lclidx,iprc,nv,psb_mpi_ipk_,mpi_max,icomm,minfo)
else
!
! 1. allgetherv
! 2. local conversion
! 3. reduce_scatter
!
!
! The basic idea is very simple.
! First we collect (to all) all the requests.
Allocate(hidx(np+1),hsz(np),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call mpi_allgather(nv,1,psb_mpi_mpk_,hsz,1,psb_mpi_mpk_,icomm,minfo)
hidx(1) = 0
do i=1, np
hidx(i+1) = hidx(i) + hsz(i)
end do
gsz = hidx(np+1)
Allocate(rmtidx(gsz),lclidx(gsz),iprc(nv),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call mpi_allgatherv(idx,hsz(me+1),psb_mpi_lpk_,&
& rmtidx,hsz,hidx,psb_mpi_lpk_,&
& icomm,minfo)
call idxmap%g2l(rmtidx(1:gsz),lclidx(1:gsz),info,owned=.true.)
!
! Reuse lclidx to encode owning process
!
do i=1, gsz
if ((1<=lclidx(i)).and.(lclidx(i)<=n_row)) then
lclidx(i) = me
else
lclidx(i) = -1
end if
end do
call mpi_reduce_scatter(lclidx,iprc,hsz,psb_mpi_ipk_,mpi_max,icomm,minfo)
end if
end if
call psb_erractionrestore(err_act)
return
base/internals/psi_adjcncy_fnd_owner.F90
+52 -10
View File
@@ -59,6 +59,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psb_timers_mod
use psb_indx_map_mod, psb_protect_name => psi_adjcncy_fnd_owner
#ifdef MPI_MOD
use mpi
@@ -85,10 +86,11 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
& last_ih, last_j, nidx, nrecv, nadj
integer(psb_lpk_) :: mglob, ih
integer(psb_ipk_) :: ictxt,np,me
logical, parameter :: gettime=.false., debug=.false.
logical, parameter :: a2av_impl=.true.
logical, parameter :: mpi_irecv_impl=.false.
logical, parameter :: psb_rcv_impl=.false.
logical, parameter :: gettime=.true., debug=.false.
integer(psb_mpk_) :: xchg_alg
logical, parameter :: do_timings=.false.
integer(psb_ipk_), save :: idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
integer(psb_ipk_), save :: idx_phase11=-1, idx_phase12=-1, idx_phase13=-1
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
character(len=20) :: name
@@ -102,6 +104,19 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
n_row = idxmap%get_lr()
n_col = idxmap%get_lc()
iictxt = ictxt
if ((do_timings).and.(idx_phase1==-1)) &
& idx_phase1 = psb_get_timer_idx("ADJ_FND_OWN: phase1 ")
if ((do_timings).and.(idx_phase2==-1)) &
& idx_phase2 = psb_get_timer_idx("ADJ_FND_OWN: phase2")
if ((do_timings).and.(idx_phase3==-1)) &
& idx_phase3 = psb_get_timer_idx("ADJ_FND_OWN: phase3")
if ((do_timings).and.(idx_phase11==-1)) &
& idx_phase11 = psb_get_timer_idx("ADJ_FND_OWN: phase11 ")
if ((do_timings).and.(idx_phase12==-1)) &
& idx_phase12 = psb_get_timer_idx("ADJ_FND_OWN: phase12")
if ((do_timings).and.(idx_phase13==-1)) &
& idx_phase13 = psb_get_timer_idx("ADJ_FND_OWN: phase13")
call psb_info(ictxt, me, np)
@@ -129,8 +144,11 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
end if
iprc = -1
! write(0,*) me,name,' Going through ',nidx,nadj
xchg_alg = psi_get_adj_alg()
select case(xchg_alg)
case(psi_adj_fnd_a2av_)
if (do_timings) call psb_tic(idx_phase1)
if (a2av_impl) then
!
! First simple minded version with auxiliary arrays
! dimensioned on NP.
@@ -146,6 +164,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
!
! First, send sizes according to adjcncy list
!
if (do_timings) call psb_tic(idx_phase11)
sdsz = 0
do j=1, nadj
sdsz(adj(j)) = nidx
@@ -154,15 +173,20 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
& rvsz,1,psb_mpi_mpk_,icomm,minfo)
if (do_timings) call psb_toc(idx_phase11)
if (do_timings) call psb_tic(idx_phase12)
rvidx(0) = 0
do i=0, np-1
rvidx(i+1) = rvidx(i) + rvsz(i)
end do
hsize = rvidx(np)
! write(0,*)me,' Check on sizes from a2a:',hsize,rvsz(:)
!
! Second, allocate buffers and exchange data
!
if (do_timings) call psb_toc(idx_phase12)
if (do_timings) call psb_tic(idx_phase13)
Allocate(rmtidx(hsize),lclidx(max(hsize,nidx*nadj)),&
& tproc(max(hsize,nidx)),stat=info)
@@ -173,7 +197,9 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
call mpi_alltoallv(idx,sdsz,sdidx,psb_mpi_lpk_,&
& rmtidx,rvsz,rvidx,psb_mpi_lpk_,icomm,iret)
if (do_timings) call psb_toc(idx_phase13)
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_phase2)
!
! Third, compute local answers
!
@@ -182,6 +208,8 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
tproc(i) = -1
if ((0 < lclidx(i)).and. (lclidx(i) <= n_row)) tproc(i) = me
end do
if (do_timings) call psb_toc(idx_phase2)
if (do_timings) call psb_tic(idx_phase3)
!
! Fourth, exchange the answers
@@ -203,10 +231,13 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
iprc(1:nidx) = max(iprc(1:nidx), lclidx(sdidx(i)+1:sdidx(i)+sdsz(i)))
end if
end do
if (do_timings) call psb_toc(idx_phase3)
if (debug) write(0,*) me,' End of adjcncy_fnd ',iprc(1:nidx)
else if (mpi_irecv_impl) then
case(psi_adj_fnd_irecv_)
if (do_timings) call psb_tic(idx_phase1)
!
! First simple minded version with auxiliary arrays
! dimensioned on NP.
@@ -216,6 +247,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
Allocate(hidx(0:np),hsz(np),sdsz(0:np-1),rvsz(0:np-1),&
& sdhd(0:np-1), rvhd(0:np-1), p2pstat(mpi_status_size,0:np-1),&
& stat=info)
if (do_timings) call psb_tic(idx_phase11)
sdhd(:) = mpi_request_null
rvhd(:) = mpi_request_null
!
@@ -255,6 +287,8 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
& p2ptag, icomm,rvhd(i),iret)
end if
end do
if (do_timings) call psb_toc(idx_phase11)
if (do_timings) call psb_tic(idx_phase12)
do j=1, nadj
if (nidx > 0) then
prc = psb_get_mpi_rank(ictxt,adj(j))
@@ -265,7 +299,12 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
& p2ptag, icomm,iret)
end if
end do
if (do_timings) call psb_toc(idx_phase12)
if (do_timings) call psb_tic(idx_phase13)
call mpi_waitall(np,rvhd,p2pstat,iret)
if (do_timings) call psb_toc(idx_phase13)
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_phase2)
!
! Third, compute local answers
@@ -275,6 +314,8 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
tproc(i) = -1
if ((0 < lclidx(i)).and. (lclidx(i) <= n_row)) tproc(i) = me
end do
if (do_timings) call psb_toc(idx_phase2)
if (do_timings) call psb_tic(idx_phase3)
!
! At this point we can reuse lclidx to receive messages
!
@@ -312,9 +353,10 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
do j = 1, nadj
iprc(1:nidx) = max(iprc(1:nidx), lclidx((j-1)*nidx+1:(j-1)*nidx+nidx))
end do
if (do_timings) call psb_toc(idx_phase3)
if (debug) write(0,*) me,' End of adjcncy_fnd ',iprc(1:nidx)
else if (psb_rcv_impl) then
case(psi_adj_fnd_pbrcv_)
Allocate(hidx(0:np),hsz(np),&
& sdsz(0:np-1),rvsz(0:np-1),stat=info)
@@ -382,11 +424,11 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
if (nidx > 0) call psb_rcv(ictxt,tproc(1:nidx),adj(j))
iprc(1:nidx) = max(iprc(1:nidx), tproc(1:nidx))
end do
else
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid exchange alg choice')
goto 9999
end if
end select
call psb_erractionrestore(err_act)
return
base/internals/psi_crea_index.f90
+23
View File
@@ -54,6 +54,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
use psb_desc_mod
use psb_error_mod
use psb_penv_mod
use psb_timers_mod
use psi_mod, psb_protect_name => psi_i_crea_index
implicit none
@@ -69,6 +70,9 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
integer(psb_ipk_),parameter :: root=psb_root_,no_comm=-1
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
logical, parameter :: do_timings=.false.
integer(psb_ipk_), save :: idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
integer(psb_ipk_), save :: idx_phase11=-1, idx_phase12=-1, idx_phase13=-1
info = psb_success_
name='psi_crea_index'
@@ -84,12 +88,26 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
call psb_errpush(info,name)
goto 9999
endif
if ((do_timings).and.(idx_phase1==-1)) &
& idx_phase1 = psb_get_timer_idx("PSI_CREA_INDEX: phase1 ")
if ((do_timings).and.(idx_phase2==-1)) &
& idx_phase2 = psb_get_timer_idx("PSI_CREA_INDEX: phase2")
if ((do_timings).and.(idx_phase3==-1)) &
& idx_phase3 = psb_get_timer_idx("PSI_CREA_INDEX: phase3")
!!$ if ((do_timings).and.(idx_phase11==-1)) &
!!$ & idx_phase11 = psb_get_timer_idx("PSI_CREA_INDEX: phase11 ")
!!$ if ((do_timings).and.(idx_phase12==-1)) &
!!$ & idx_phase12 = psb_get_timer_idx("PSI_CREA_INDEX: phase12")
!!$ if ((do_timings).and.(idx_phase13==-1)) &
!!$ & idx_phase13 = psb_get_timer_idx("PSI_CREA_INDEX: phase13")
! ...extract dependence list (ordered list of identifer process
! which every process must communcate with...
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': calling extract_dep_list'
mode = 1
if (do_timings) call psb_tic(idx_phase1)
call psi_extract_dep_list(ictxt,&
& desc_a%is_bld(), desc_a%is_upd(),&
@@ -105,6 +123,8 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
! ...now process root contains dependence list of all processes...
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': root sorting dep list'
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_phase2)
call psi_dl_check(dep_list,dl_lda,np,length_dl)
@@ -114,6 +134,8 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_sort_dl')
goto 9999
end if
if (do_timings) call psb_toc(idx_phase2)
if (do_timings) call psb_tic(idx_phase3)
if(debug_level >= psb_debug_inner_)&
& write(debug_unit,*) me,' ',trim(name),': calling psi_desc_index'
@@ -128,6 +150,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_desc_index')
goto 9999
end if
if (do_timings) call psb_toc(idx_phase3)
deallocate(dep_list,length_dl)
if(debug_level >= psb_debug_inner_) &
base/internals/psi_desc_impl.f90
+30 -1
View File
@@ -63,6 +63,7 @@ end subroutine psi_renum_index
subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
use psi_mod, psi_protect_name => psi_i_cnv_dsc
use psb_timers_mod
use psb_realloc_mod
implicit none
@@ -82,6 +83,9 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: debug=.false.
character(len=20) :: name
logical, parameter :: do_timings=.false.
integer(psb_ipk_), save :: idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
integer(psb_ipk_), save :: idx_phase11=-1, idx_phase12=-1, idx_phase13=-1
name='psi_cnv_desc'
call psb_get_erraction(err_act)
@@ -97,8 +101,23 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
call psb_errpush(info,name)
goto 9999
endif
if ((do_timings).and.(idx_phase1==-1)) &
& idx_phase1 = psb_get_timer_idx("PSI_CNV_DSC: phase1 ")
if ((do_timings).and.(idx_phase2==-1)) &
& idx_phase2 = psb_get_timer_idx("PSI_CNV_DSC: phase2")
if ((do_timings).and.(idx_phase3==-1)) &
& idx_phase3 = psb_get_timer_idx("PSI_CNV_DSC: phase3")
if ((do_timings).and.(idx_phase11==-1)) &
& idx_phase11 = psb_get_timer_idx("PSI_CNV_DSC: phase11 ")
if ((do_timings).and.(idx_phase12==-1)) &
& idx_phase12 = psb_get_timer_idx("PSI_CNV_DSC: phase12")
if ((do_timings).and.(idx_phase13==-1)) &
& idx_phase13 = psb_get_timer_idx("PSI_CNV_DSC: phase13")
if (do_timings) call psb_tic(idx_phase1)
if (do_timings) call psb_tic(idx_phase11)
! first the halo index
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',&
& size(halo_in)
@@ -111,6 +130,8 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo'
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
if (do_timings) call psb_toc(idx_phase11)
if (do_timings) call psb_tic(idx_phase12)
! then ext index
@@ -124,6 +145,8 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext'
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap'
if (do_timings) call psb_toc(idx_phase12)
if (do_timings) call psb_tic(idx_phase13)
! then the overlap index
call psi_crea_index(cdesc,ovrlap_in, idx_out,nxch,nsnd,nrcv,info)
@@ -136,6 +159,9 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc')
goto 9999
end if
if (do_timings) call psb_toc(idx_phase13)
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_phase2)
! next ovrlap_elem
@@ -161,6 +187,8 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc')
goto 9999
end if
if (do_timings) call psb_toc(idx_phase2)
if (do_timings) call psb_tic(idx_phase3)
! finally bnd_elem
call psi_crea_bnd_elem(idx_out,cdesc,info)
@@ -177,7 +205,8 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
goto 9999
end if
if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem'
if (do_timings) call psb_toc(idx_phase3)
call psb_erractionrestore(err_act)
return
base/internals/psi_desc_index.F90
+79 -10
View File
@@ -128,11 +128,15 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:),&
& bsdindx(:),sdsz(:)
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, sz
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:)
integer(psb_ipk_) :: ihinsz,ntot,k,err_act,nidx,&
& idxr, idxs, iszs, iszr, nesd, nerv
& idxr, idxs, iszs, iszr, nesd, nerv, ixp, idx
integer(psb_mpk_) :: icomm, minfo
logical,parameter :: usempi=.true.
logical, parameter :: usempi=.false.
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
@@ -255,12 +259,12 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
call desc%indxmap%l2g(index_in(i+1:i+nerv),&
& sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),&
& info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g')
goto 9999
end if
bsdindx(proc+1) = bsdindx(proc+1) + nerv
i = i + nerv + 1
end do
@@ -282,11 +286,76 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
idxr = idxr + rvsz(proc+1)
end do
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_lpk_,&
& rcvbuf,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv')
goto 9999
if (usempi) then
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_lpk_,&
& rcvbuf,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv')
goto 9999
end if
else
if (.true.) then
allocate(prcid(length_dl),rvhd(length_dl))
prcid = -1
ixp = 1
do i=1, length_dl
proc = dep_list(i)
prcid(ixp) = psb_get_mpi_rank(ictxt,proc)
sz = rvsz(proc+1)
if (sz > 0) then
p2ptag = psb_long_tag
idx = brvindx(proc+1)
call mpi_irecv(rcvbuf(idx+1:idx+sz),sz,&
& psb_mpi_lpk_, prcid(ixp), p2ptag, icomm,&
& rvhd(ixp),iret)
end if
ixp = ixp + 1
end do
ixp = 1
do i=1, length_dl
proc = dep_list(i)
prcid(ixp) = psb_get_mpi_rank(ictxt,proc)
sz = sdsz(proc+1)
if (sz > 0) then
p2ptag = psb_long_tag
idx = bsdindx(proc+1)
call mpi_send(sndbuf(idx+1:idx+sz),sz,&
& psb_mpi_lpk_, prcid(ixp), p2ptag, &
& icomm,iret)
end if
ixp = ixp + 1
end do
ixp = 1
do i=1, length_dl
proc = dep_list(i)
prcid(ixp) = psb_get_mpi_rank(ictxt,proc)
sz = rvsz(proc+1)
if (sz > 0) then
call mpi_wait(rvhd(ixp),p2pstat,iret)
end if
ixp = ixp + 1
end do
else
do i=1, length_dl
proc = dep_list(i)
sz = sdsz(proc+1)
idx = bsdindx(proc+1)
if (sz > 0) then
call psb_snd(ictxt,sndbuf(idx+1:idx+sz), proc)
end if
end do
do i=1, length_dl
proc = dep_list(i)
sz = rvsz(proc+1)
idx = brvindx(proc+1)
if (sz > 0) then
call psb_rcv(ictxt,rcvbuf(idx+1:idx+sz),proc)
end if
end do
end if
end if
!
@@ -327,7 +396,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_i_desc_index
base/internals/psi_dl_check.f90
+1 -1
View File
@@ -79,7 +79,7 @@ subroutine psi_i_dl_check(dep_list,dl_lda,np,length_dl)
! ...add proc to proc2 s dep_list.....',proc,proc2
length_dl(proc2) = length_dl(proc2)+1
if (length_dl(proc2) > size(dep_list,1)) then
write(psb_err_unit,*)'error in crea_halo', proc2,proc,&
write(psb_err_unit,*)'error in dl_check', proc2,proc,&
& length_dl(proc2),'>',size(dep_list,1)
endif
dep_list(length_dl(proc2),proc2) = proc
base/internals/psi_graph_fnd_owner.F90
+60 -30
View File
@@ -101,13 +101,13 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
integer(psb_ipk_), allocatable :: tprc(:), tsmpl(:), ladj(:)
integer(psb_mpk_) :: icomm, minfo, iictxt
integer(psb_ipk_) :: i,n_row,n_col,err_act,ip,j,ipnt, nsampl_out,&
& nv, n_answers, n_rest, nsampl_in, locr_max, &
& nrest_max, nadj, maxspace, mxnsin
& nv, n_answers, nreqst, nsampl_in, locr_max, &
& nreqst_max, nadj, maxspace, mxnsin
integer(psb_lpk_) :: mglob, ih
integer(psb_ipk_) :: ictxt,np,me, nresp
integer(psb_ipk_), parameter :: nt=4
integer(psb_ipk_) :: tmpv(4)
logical, parameter :: do_timings=.false., trace=.false.
logical, parameter :: do_timings=.false., trace=.false., debugsz=.false.
integer(psb_ipk_), save :: idx_sweep0=-1, idx_loop_a2a=-1, idx_loop_neigh=-1
real(psb_dpk_) :: t0, t1, t2, t3, t4
character(len=20) :: name
@@ -162,20 +162,25 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
!
call psb_safe_ab_cpy(idxmap%p_adjcncy,ladj,info)
nadj = psb_size(ladj)
! This makes ladj allocated with size 0 just in case
! This makes ladj allocated with size 0 if needed, as opposed to unallocated
call psb_realloc(nadj,ladj,info)
n_rest = nv - n_answers
nrest_max = n_rest
!
! Throughout the subroutine, nreqst is the number of local inquiries
! that have not been answered yet
!
nreqst = nv - n_answers
nreqst_max = nreqst
!
! Choice of maxspace should be adjusted to account for a default
! "sensible" size and/or a user-specified value
!
tmpv(1) = nadj
tmpv(2) = nrest_max
tmpv(2) = nreqst_max
tmpv(3) = n_row
tmpv(4) = psb_cd_get_maxspace()
call psb_max(ictxt,tmpv)
nreqst_max = tmpv(2)
locr_max = tmpv(3)
maxspace = nt*locr_max
if (tmpv(4) > 0) maxspace = min(maxspace,tmpv(4))
@@ -187,18 +192,21 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
! Do a preliminary run on the user-defined adjacency lists
!
if (trace.and.(me == 0)) write(0,*) ' Initial sweep on user-defined topology'
nsampl_in = min(n_rest,max(1,(maxspace+max(1,nadj)-1))/(max(1,nadj)))
if (debugsz) write(0,*) me,' Initial sweep on user-defined topology',nreqst
nsampl_in = min(nreqst,max(1,(maxspace+max(1,nadj)-1))/(max(1,nadj)))
call psi_adj_fnd_sweep(idx,iprc,ladj,idxmap,nsampl_in,n_answers)
call idxmap%xtnd_p_adjcncy(ladj)
n_rest = nv - n_answers
nrest_max = n_rest
call psb_max(ictxt,nrest_max)
if (trace.and.(me == 0)) write(0,*) ' After initial sweep:',nrest_max
nreqst = nv - n_answers
nreqst_max = nreqst
call psb_max(ictxt,nreqst_max)
if (trace.and.(me == 0)) write(0,*) ' After initial sweep:',nreqst_max
if (debugsz) write(0,*) me,' After sweep on user-defined topology',nreqst_max
end if
if (do_timings) call psb_toc(idx_sweep0)
fnd_owner_loop: do while (nrest_max>0)
if (do_timings) call psb_tic(idx_loop_a2a)
fnd_owner_loop: do while (nreqst_max>0)
if (do_timings) call psb_tic(idx_loop_a2a)
if (debugsz) write(0,*) me,' fnd_owner_loop',nreqst_max
!
! The basic idea of this loop is to alternate between
! searching through all processes and searching
@@ -207,28 +215,34 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
! 1. Select a sample such that the total size is <= maxspace
! sample query is then sent to all processes
!
! if (trace.and.(me == 0)) write(0,*) 'Looping in graph_fnd_owner: ', nrest_max
nsampl_in = min(n_rest,max(1,(maxspace+np-1)/np))
! if (trace.and.(me == 0)) write(0,*) 'Looping in graph_fnd_owner: ', nreqst_max
nsampl_in = psb_cd_get_samplesize()
nsampl_in = min(max(1,(maxspace+np-1)/np),nsampl_in)
!
! Choose a sample, should it be done in this simplistic way?
! Note: nsampl_in is a hint, not an absolute, hence nsampl_out
!
ipnt = 1
!!$ write(0,*) me,' Into first sampling ',nsampl_in
call psi_get_sample(ipnt, idx,iprc,tidx,tsmpl,nsampl_in,nsampl_out)
call psi_get_sample(ipnt, idx,iprc,tidx,tsmpl,nsampl_in,nsampl_out, pad=.true.)
nsampl_in = min(nsampl_out,nsampl_in)
!!$ write(0,*) me,' From first sampling ',nsampl_in
if (debugsz) write(0,*) me,' From first sampling ',nsampl_in
!
! 2. Do a search on all processes; this is supposed to find
! the owning process for all inputs;
!
call psi_a2a_fnd_owner(tidx(1:nsampl_in),tprc,idxmap,info)
call psi_a2a_fnd_owner(tidx(1:nsampl_in),tprc,idxmap,info, samesize=.true.)
if (debugsz) write(0,*) me,' From a2a_fnd_owner ',info
!
! We might have padded when looking for owners, so the actual samples
! could be less than they appear. Should be explained better.
!
nsampl_in = min(nreqst,nsampl_in)
call psi_cpy_out(iprc,tprc,tsmpl,nsampl_in,nsampl_out)
if (nsampl_out /= nsampl_in) then
write(0,*) me,'Warning: indices not found by a2a_fnd_owner ',nsampl_out,nsampl_in
end if
n_answers = n_answers + nsampl_out
n_rest = nv - n_answers
nreqst = nv - n_answers
!
! 3. Extract the resulting adjacency list and add it to the
! indxmap;
@@ -245,18 +259,18 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
! Need to set up a proper loop here to have a complete
! sweep over the input vector. Done inside adj_fnd_sweep.
!
!!$ write(0,*) me,' After a2a ',n_rest
nsampl_in = min(n_rest,max(1,(maxspace+max(1,nadj)-1))/(max(1,nadj)))
!!$ write(0,*) me,' After a2a ',nreqst
nsampl_in = min(nreqst,max(1,(maxspace+max(1,nadj)-1))/(max(1,nadj)))
mxnsin = nsampl_in
call psb_max(ictxt,mxnsin)
!!$ write(0,*) me, ' mxnsin ',mxnsin
if (mxnsin>0) call psi_adj_fnd_sweep(idx,iprc,ladj,idxmap,nsampl_in,n_answers)
call idxmap%xtnd_p_adjcncy(ladj)
n_rest = nv - n_answers
nrest_max = n_rest
call psb_max(ictxt,nrest_max)
if (trace.and.(me == 0)) write(0,*) ' fnd_owner_loop remaining:',nrest_max
nreqst = nv - n_answers
nreqst_max = nreqst
call psb_max(ictxt,nreqst_max)
if (trace.and.(me == 0)) write(0,*) ' fnd_owner_loop remaining:',nreqst_max
if (do_timings) call psb_toc(idx_loop_neigh)
end do fnd_owner_loop
@@ -269,16 +283,23 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
contains
subroutine psi_get_sample(ipntidx,idx,iprc,tidx,tsmpl,ns_in,ns_out)
subroutine psi_get_sample(ipntidx,idx,iprc,tidx,tsmpl,ns_in,ns_out,pad)
implicit none
integer(psb_ipk_), intent(inout) :: ipntidx
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), intent(in) :: ns_in, iprc(:)
integer(psb_lpk_), intent(out) :: tidx(:)
integer(psb_ipk_), intent(out) :: tsmpl(:), ns_out
logical, intent(in), optional :: pad
!
integer(psb_ipk_) :: nv, ns
integer(psb_ipk_) :: nv, ns, k
logical :: pad_
if (present(pad)) then
pad_ = pad
else
pad_ = .false.
end if
nv = size(idx)
!
! Choose a sample, should it be done in this simplistic way?
@@ -287,9 +308,11 @@ contains
!
! ns_in == 0 means that on the outside we figure there's
! nothing left, but we are here because we have to synchronize.
! Make sure we sweep through the entire vector immediately
! Make sure we sweep through the entire vector immediately.
! But also make sure we do not overrun tsmpl
!
if (ns == 0) ns = nv
ns = min(ns,size(tsmpl))
ns_out = 0
do while (ipntidx<= nv)
@@ -301,6 +324,13 @@ contains
ipntidx = ipntidx + 1
if (ns_out >= ns) exit
end do
if (pad_) then
do k = ns_out+1, ns
tsmpl(k) = -1
tidx(k) = -1
end do
ns_out = ns
end if
end subroutine psi_get_sample
base/internals/psi_indx_map_fnd_owner.F90
+62 -2
View File
@@ -74,7 +74,8 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
integer(psb_ipk_), allocatable :: hhidx(:)
integer(psb_mpk_) :: icomm, minfo, iictxt
integer(psb_ipk_) :: i, err_act, hsize, nv
integer(psb_ipk_) :: i, err_act, hsize
integer(psb_lpk_) :: nv
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: ictxt,np,me, nresp
logical, parameter :: gettime=.false.
@@ -140,7 +141,66 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info)
else
call psi_graph_fnd_owner(idx,iprc,idxmap,info)
if (allocated(idxmap%halo_owner)) then
!
! Maybe we are coming here after a REINIT event.
! In this case, reuse the existing information as much as possible.
!
block
integer(psb_ipk_), allocatable :: tprc(:), lidx(:)
integer(psb_lpk_), allocatable :: tidx(:)
integer(psb_lpk_) :: k1, k2, nh
allocate(lidx(nv),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
!
! Get local answers, if any
!
call idxmap%g2l(idx,lidx,info,owned=.false.)
call idxmap%fnd_halo_owner(lidx,iprc,info)
nh = count(iprc<0)
!write(0,*) me,'Going through new impl from ',nv,' to ',nh
allocate(tidx(nh),tprc(nh),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
!
! Prepare remote queries
!
k2 = 0
do k1 = 1, nv
if (iprc(k1) < 0) then
k2 = k2 + 1
if (k2 > nh) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong auxiliary count')
goto 9999
end if
tidx(k2) = idx(k1)
end if
end do
call psi_graph_fnd_owner(tidx,tprc,idxmap,info)
k2 = 0
do k1 = 1, nv
if (iprc(k1) < 0) then
k2 = k2 + 1
if (k2 > nh) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Wrong auxiliary count')
goto 9999
end if
iprc(k1) = tprc(k2)
end if
end do
end block
else
call psi_graph_fnd_owner(idx,iprc,idxmap,info)
end if
end if
base/modules/Makefile
+6 -2
View File
@@ -153,9 +153,13 @@ penv/psi_collective_mod.o: penv/psi_e_collective_mod.o \
penv/psi_z_collective_mod.o
penv/psi_m_p2p_mod.o penv/psi_e_p2p_mod.o penv/psi_s_p2p_mod.o \
penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o\
penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o: penv/psi_penv_mod.o
penv/psi_e_collective_mod.o penv/psi_m_collective_mod.o penv/psi_s_collective_mod.o \
penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_mod.o: penv/psi_penv_mod.o
penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_mod.o: penv/psi_penv_mod.o \
penv/psi_m_p2p_mod.o penv/psi_e_p2p_mod.o penv/psi_s_p2p_mod.o \
penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o
auxil/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o
desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o desc/psb_desc_const_mod.o
base/modules/auxil/psb_i2_hsort_mod.f90
+125
View File
@@ -0,0 +1,125 @@
!
! 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_i2_hsort_mod
use psb_const_mod
interface psb_hsort
subroutine psb_i2hsort(x,ix,dir,flag)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_i2hsort
end interface psb_hsort
interface psi_insert_heap
subroutine psi_i2_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_i2pk_), intent(in) :: key
integer(psb_i2pk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2_insert_heap
end interface psi_insert_heap
interface psi_idx_insert_heap
subroutine psi_i2_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_i2pk_), intent(in) :: key
integer(psb_i2pk_), 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_i2_idx_insert_heap
end interface psi_idx_insert_heap
interface psi_heap_get_first
subroutine psi_i2_heap_get_first(key,last,heap,dir,info)
import
implicit none
integer(psb_i2pk_), intent(inout) :: key
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(in) :: dir
integer(psb_i2pk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2_heap_get_first
end interface psi_heap_get_first
interface psi_idx_heap_get_first
subroutine psi_i2_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
integer(psb_i2pk_), intent(inout) :: key
integer(psb_ipk_), intent(out) :: index
integer(psb_i2pk_), 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_i2_idx_heap_get_first
end interface psi_idx_heap_get_first
end module psb_i2_hsort_mod
base/modules/auxil/psb_i2_ip_reord_mod.F90
+320
View File
@@ -0,0 +1,320 @@
!
! 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.
!
!
!
! Reorder (an) input vector(s) based on a list sort output.
! Based on: D. E. Knuth: The Art of Computer Programming
! vol. 3: Sorting and Searching, Addison Wesley, 1973
! ex. 5.2.12
!
!
module psb_i2_ip_reord_mod
use psb_const_mod
interface psb_ip_reord
module procedure psb_ip_reord_i21m,&
& psb_ip_reord_i21m1, psb_ip_reord_i21m2,&
& psb_ip_reord_i21m3
module procedure psb_ip_reord_i21e,&
& psb_ip_reord_i21e1, psb_ip_reord_i21e2,&
& psb_ip_reord_i21e3
end interface
contains
subroutine psb_ip_reord_i21m(n,x,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_mpk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_mpk_) :: lswap, lp, k
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21m
subroutine psb_ip_reord_i21m1(n,x,indx,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_mpk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_mpk_) :: indx(*)
integer(psb_mpk_) :: lswap, lp, k, ixswap
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
ixswap = indx(lp)
indx(lp) = indx(k)
indx(k) = ixswap
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21m1
subroutine psb_ip_reord_i21m2(n,x,i1,i2,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_mpk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_mpk_) :: i1(*), i2(*)
integer(psb_mpk_) :: lswap, lp, k, isw1, isw2
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
isw1 = i1(lp)
i1(lp) = i1(k)
i1(k) = isw1
isw2 = i2(lp)
i2(lp) = i2(k)
i2(k) = isw2
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21m2
subroutine psb_ip_reord_i21m3(n,x,i1,i2,i3,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_mpk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_mpk_) :: i1(*), i2(*), i3(*)
integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
isw1 = i1(lp)
i1(lp) = i1(k)
i1(k) = isw1
isw2 = i2(lp)
i2(lp) = i2(k)
i2(k) = isw2
isw3 = i3(lp)
i3(lp) = i3(k)
i3(k) = isw3
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21m3
subroutine psb_ip_reord_i21e(n,x,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_epk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_epk_) :: lswap, lp, k
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21e
subroutine psb_ip_reord_i21e1(n,x,indx,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_epk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_epk_) :: indx(*)
integer(psb_epk_) :: lswap, lp, k, ixswap
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
ixswap = indx(lp)
indx(lp) = indx(k)
indx(k) = ixswap
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21e1
subroutine psb_ip_reord_i21e2(n,x,i1,i2,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_epk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_epk_) :: i1(*), i2(*)
integer(psb_epk_) :: lswap, lp, k, isw1, isw2
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
isw1 = i1(lp)
i1(lp) = i1(k)
i1(k) = isw1
isw2 = i2(lp)
i2(lp) = i2(k)
i2(k) = isw2
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21e2
subroutine psb_ip_reord_i21e3(n,x,i1,i2,i3,iaux)
integer(psb_ipk_), intent(in) :: n
integer(psb_epk_) :: iaux(0:*)
integer(psb_i2pk_) :: x(*)
integer(psb_epk_) :: i1(*), i2(*), i3(*)
integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3
integer(psb_i2pk_) :: swap
lp = iaux(0)
k = 1
do
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
end do
swap = x(lp)
x(lp) = x(k)
x(k) = swap
isw1 = i1(lp)
i1(lp) = i1(k)
i1(k) = isw1
isw2 = i2(lp)
i2(lp) = i2(k)
i2(k) = isw2
isw3 = i3(lp)
i3(lp) = i3(k)
i3(k) = isw3
lswap = iaux(lp)
iaux(lp) = iaux(k)
iaux(k) = lp
lp = lswap
k = k + 1
enddo
return
end subroutine psb_ip_reord_i21e3
end module psb_i2_ip_reord_mod
base/modules/auxil/psb_i2_isort_mod.f90
+105
View File
@@ -0,0 +1,105 @@
!
! 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_i2_isort_mod
use psb_const_mod
interface psb_isort
subroutine psb_i2isort(x,ix,dir,flag)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_i2isort
end interface psb_isort
interface
subroutine psi_i2isrx_up(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2isrx_up
subroutine psi_i2isrx_dw(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2isrx_dw
subroutine psi_i2isr_up(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2isr_up
subroutine psi_i2isr_dw(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2isr_dw
subroutine psi_i2aisrx_up(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aisrx_up
subroutine psi_i2aisrx_dw(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aisrx_dw
subroutine psi_i2aisr_up(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aisr_up
subroutine psi_i2aisr_dw(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aisr_dw
end interface
end module psb_i2_isort_mod
base/modules/auxil/psb_i2_msort_mod.f90
+111
View File
@@ -0,0 +1,111 @@
!
! 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_i2_msort_mod
use psb_const_mod
interface psb_isaperm
logical function psb_i2isaperm(n,eip)
import
integer(psb_i2pk_), intent(in) :: n
integer(psb_i2pk_), intent(in) :: eip(n)
end function psb_i2isaperm
end interface psb_isaperm
interface psb_msort_unique
subroutine psb_i2msort_u(x,nout,dir)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: nout
integer(psb_ipk_), optional, intent(in) :: dir
end subroutine psb_i2msort_u
end interface psb_msort_unique
interface psb_msort
subroutine psb_i2msort(x,ix,dir,flag)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_i2msort
end interface psb_msort
interface psi_msort_up
subroutine psi_i2_msort_up(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_i2pk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i2_msort_up
end interface psi_msort_up
interface psi_msort_dw
subroutine psi_i2_msort_dw(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_i2pk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i2_msort_dw
end interface psi_msort_dw
interface psi_amsort_up
subroutine psi_i2_amsort_up(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_i2pk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i2_amsort_up
end interface psi_amsort_up
interface psi_amsort_dw
subroutine psi_i2_amsort_dw(n,k,l,iret)
import
implicit none
integer(psb_ipk_) :: n, iret
integer(psb_i2pk_) :: k(n)
integer(psb_ipk_) :: l(0:n+1)
end subroutine psi_i2_amsort_dw
end interface psi_amsort_dw
end module psb_i2_msort_mod
base/modules/auxil/psb_i2_qsort_mod.f90
+123
View File
@@ -0,0 +1,123 @@
!
! 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_i2_qsort_mod
use psb_const_mod
interface psb_bsrch
function psb_i2bsrch(key,n,v) result(ipos)
import
integer(psb_ipk_) :: ipos, n
integer(psb_i2pk_) :: key
integer(psb_i2pk_) :: v(:)
end function psb_i2bsrch
end interface psb_bsrch
interface psb_ssrch
function psb_i2ssrch(key,n,v) result(ipos)
import
implicit none
integer(psb_ipk_) :: ipos, n
integer(psb_i2pk_) :: key
integer(psb_i2pk_) :: v(:)
end function psb_i2ssrch
end interface psb_ssrch
interface psb_qsort
subroutine psb_i2qsort(x,ix,dir,flag)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), optional, intent(in) :: dir, flag
integer(psb_ipk_), optional, intent(inout) :: ix(:)
end subroutine psb_i2qsort
end interface psb_qsort
interface
subroutine psi_i2qsrx_up(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2qsrx_up
subroutine psi_i2qsrx_dw(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2qsrx_dw
subroutine psi_i2qsr_up(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2qsr_up
subroutine psi_i2qsr_dw(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2qsr_dw
subroutine psi_i2aqsrx_up(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aqsrx_up
subroutine psi_i2aqsrx_dw(n,x,ix)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aqsrx_dw
subroutine psi_i2aqsr_up(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aqsr_up
subroutine psi_i2aqsr_dw(n,x)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n
end subroutine psi_i2aqsr_dw
end interface
end module psb_i2_qsort_mod
base/modules/auxil/psb_i2_realloc_mod.F90
+1027
View File
File diff suppressed because it is too large Load Diff
base/modules/auxil/psi_i2_serial_mod.f90
+143
View File
@@ -0,0 +1,143 @@
!
! 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.
!
!
module psi_i2_serial_mod
use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_
interface psb_gelp
! 2-D version
subroutine psb_i2gelp(trans,iperm,x,info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_ipk_), intent(in) :: iperm(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in) :: trans
end subroutine psb_i2gelp
subroutine psb_i2gelpv(trans,iperm,x,info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: iperm(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in) :: trans
end subroutine psb_i2gelpv
end interface psb_gelp
interface psb_geaxpby
subroutine psi_i2axpby(m,n,alpha, x, beta, y, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m, n
integer(psb_i2pk_), intent (in) :: x(:,:)
integer(psb_i2pk_), intent (inout) :: y(:,:)
integer(psb_i2pk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2axpby
subroutine psi_i2axpbyv(m,alpha, x, beta, y, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_i2pk_), intent (in) :: x(:)
integer(psb_i2pk_), intent (inout) :: y(:)
integer(psb_i2pk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2axpbyv
subroutine psi_i2axpbyv2(m,alpha, x, beta, y, z, info)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_i2pk_), intent (in) :: x(:)
integer(psb_i2pk_), intent (in) :: y(:)
integer(psb_i2pk_), intent (in) :: z(:)
integer(psb_i2pk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2axpbyv2
end interface psb_geaxpby
interface psi_gth
subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, k, idx(:)
integer(psb_i2pk_) :: x(:,:), y(:),alpha,beta
end subroutine psi_i2gthmv
subroutine psi_i2gthv(n,idx,alpha,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, idx(:)
integer(psb_i2pk_) :: x(:), y(:),alpha,beta
end subroutine psi_i2gthv
subroutine psi_i2gthzmv(n,k,idx,x,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, k, idx(:)
integer(psb_i2pk_) :: x(:,:), y(:)
end subroutine psi_i2gthzmv
subroutine psi_i2gthzmm(n,k,idx,x,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, k, idx(:)
integer(psb_i2pk_) :: x(:,:), y(:,:)
end subroutine psi_i2gthzmm
subroutine psi_i2gthzv(n,idx,x,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, idx(:)
integer(psb_i2pk_) :: x(:), y(:)
end subroutine psi_i2gthzv
end interface psi_gth
interface psi_sct
subroutine psi_i2sctmm(n,k,idx,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, k, idx(:)
integer(psb_i2pk_) :: beta, x(:,:), y(:,:)
end subroutine psi_i2sctmm
subroutine psi_i2sctmv(n,k,idx,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, k, idx(:)
integer(psb_i2pk_) :: beta, x(:), y(:,:)
end subroutine psi_i2sctmv
subroutine psi_i2sctv(n,idx,x,beta,y)
import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_
implicit none
integer(psb_ipk_) :: n, idx(:)
integer(psb_i2pk_) :: beta, x(:), y(:)
end subroutine psi_i2sctv
end interface psi_sct
end module psi_i2_serial_mod
base/modules/comm/psb_e_comm_a_mod.f90
+2 -1
View File
@@ -30,7 +30,8 @@
!
!
module psb_e_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, &
& psb_epk_, psb_mpk_, psb_i2pk_
interface psb_ovrl
subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode)
base/modules/comm/psb_i2_comm_a_mod.f90
+123
View File
@@ -0,0 +1,123 @@
!
! 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.
!
!
module psb_i2_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, &
& psb_epk_, psb_mpk_, psb_i2pk_
interface psb_ovrl
subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode)
import
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
end subroutine psb_i2ovrlm
subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode)
import
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_i2ovrlv
end interface psb_ovrl
interface psb_halo
subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data)
import
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
end subroutine psb_i2halom
subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data)
import
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_i2halov
end interface psb_halo
interface psb_scatter
subroutine psb_i2scatterm(globx, locx, desc_a, info, root)
import
implicit none
integer(psb_i2pk_), intent(out), allocatable :: locx(:,:)
integer(psb_i2pk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_i2scatterm
subroutine psb_i2scatterv(globx, locx, desc_a, info, root)
import
implicit none
integer(psb_i2pk_), intent(out), allocatable :: locx(:)
integer(psb_i2pk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_i2scatterv
end interface psb_scatter
interface psb_gather
subroutine psb_i2gatherm(globx, locx, desc_a, info, root)
import
implicit none
integer(psb_i2pk_), intent(in) :: locx(:,:)
integer(psb_i2pk_), intent(out), allocatable :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_i2gatherm
subroutine psb_i2gatherv(globx, locx, desc_a, info, root)
import
implicit none
integer(psb_i2pk_), intent(in) :: locx(:)
integer(psb_i2pk_), intent(out), allocatable :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_i2gatherv
end interface psb_gather
end module psb_i2_comm_a_mod
base/modules/comm/psb_m_comm_a_mod.f90
+2 -1
View File
@@ -30,7 +30,8 @@
!
!
module psb_m_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, &
& psb_epk_, psb_mpk_, psb_i2pk_
interface psb_ovrl
subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode)
base/modules/comm/psi_i2_comm_a_mod.f90
+166
View File
@@ -0,0 +1,166 @@
!
! 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.
!
!
module psi_i2_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_
interface psi_swapdata
subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag, n
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:,:), beta
integer(psb_i2pk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swapdatam
subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
integer(psb_i2pk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swapdatav
subroutine psi_i2swapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:,:), beta
integer(psb_i2pk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2swapidxm
subroutine psi_i2swapidxv(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
integer(psb_i2pk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2swapidxv
end interface psi_swapdata
interface psi_swaptran
subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag, n
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:,:), beta
integer(psb_i2pk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swaptranm
subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
integer(psb_i2pk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swaptranv
subroutine psi_i2tranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:,:), beta
integer(psb_i2pk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2tranidxm
subroutine psi_i2tranidxv(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
integer(psb_i2pk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2tranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
import
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_updr1
subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
import
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_updr2
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_saver1
subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
import
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_saver2
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
import
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_restrr1
subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
import
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_restrr2
end interface psi_ovrl_restore
end module psi_i2_comm_a_mod
base/modules/comm/psi_i_comm_v_mod.f90
+2 -1
View File
@@ -30,7 +30,8 @@
!
!
module psi_i_comm_v_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, &
& psb_lpk_, psb_epk_, psb_i2pk_
use psb_i_base_vect_mod, only : psb_i_base_vect_type
use psb_i_base_multivect_mod, only : psb_i_base_multivect_type
base/modules/comm/psi_l_comm_v_mod.f90
+2 -1
View File
@@ -30,7 +30,8 @@
!
!
module psi_l_comm_v_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, &
& psb_lpk_, psb_epk_, psb_i2pk_
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_, psb_i_base_vect_type
use psb_l_base_vect_mod, only : psb_l_base_vect_type
use psb_l_base_multivect_mod, only : psb_l_base_multivect_type
base/modules/desc/psb_desc_const_mod.f90
+10 -2
View File
@@ -104,9 +104,17 @@ module psb_desc_const_mod
integer(psb_ipk_), parameter :: psb_hash_bits = 16
integer(psb_ipk_), parameter :: psb_max_hash_bits = 22
integer(psb_ipk_), parameter :: psb_hash_size = 2**psb_hash_bits, psb_hash_mask=psb_hash_size-1
integer(psb_ipk_), parameter :: psb_default_large_threshold=1*1024*1024
integer(psb_ipk_), parameter :: psb_hpnt_nentries_ = 7
integer(psb_ipk_), parameter :: psb_default_large_threshold=1*1024*1024
!
! Choice of algorithm for sparse matrix A2AV
!
integer(psb_ipk_), parameter :: psb_sp_a2av_smpl_triad_ = 1
integer(psb_ipk_), parameter :: psb_sp_a2av_smpl_v_ = 2
integer(psb_ipk_), parameter :: psb_sp_a2av_mpi_ = 3
integer(psb_ipk_), parameter :: psb_sp_a2av_alg_min_ = psb_sp_a2av_smpl_triad_
integer(psb_ipk_), parameter :: psb_sp_a2av_alg_max_ = psb_sp_a2av_mpi_
!
! Constants for desc_a handling
!
base/modules/desc/psb_desc_mod.F90
+33 -26
View File
@@ -285,14 +285,6 @@ module psb_desc_mod
module procedure psb_cdfree
end interface psb_free
interface psb_cd_set_maxspace
module procedure psb_cd_set_maxspace
end interface psb_cd_set_maxspace
interface psb_cd_get_maxspace
module procedure psb_cd_get_maxspace
end interface psb_cd_get_maxspace
interface psb_cd_set_large_threshold
module procedure psb_i_cd_set_large_threshold
end interface psb_cd_set_large_threshold
@@ -302,7 +294,15 @@ module psb_desc_mod
module procedure psb_l_cd_set_large_threshold
end interface psb_cd_set_large_threshold
#endif
interface psb_set_sp_a2av_alg
module procedure psb_m_set_sp_a2av_alg, psb_e_set_sp_a2av_alg
end interface psb_set_sp_a2av_alg
interface psb_get_sp_a2av_alg
module procedure psb_m_get_sp_a2av_alg
end interface psb_get_sp_a2av_alg
private :: nullify_desc, cd_get_fmt,&
& cd_l2gs1, cd_l2gs2, cd_l2gv1, cd_l2gv2, cd_g2ls1,&
& cd_g2ls2, cd_g2lv1, cd_g2lv2, cd_g2ls1_ins,&
@@ -310,11 +310,33 @@ module psb_desc_mod
integer(psb_lpk_), private, save :: cd_large_threshold = psb_default_large_threshold
integer(psb_ipk_), private, save :: cd_maxspace = -1
integer(psb_ipk_), private, save :: sp_a2av_alg = psb_sp_a2av_smpl_triad_
contains
function psb_m_get_sp_a2av_alg() result(val)
implicit none
integer(psb_mpk_) :: val
val = sp_a2av_alg
end function psb_m_get_sp_a2av_alg
subroutine psb_m_set_sp_a2av_alg(val)
implicit none
integer(psb_mpk_), intent(in) :: val
if ((psb_sp_a2av_alg_min_ <= val).and.(val<=psb_sp_a2av_alg_max_)) &
& sp_a2av_alg = val
end subroutine psb_m_set_sp_a2av_alg
subroutine psb_e_set_sp_a2av_alg(val)
implicit none
integer(psb_epk_), intent(in) :: val
if ((psb_sp_a2av_alg_min_ <= val).and.(val<=psb_sp_a2av_alg_max_)) &
& sp_a2av_alg = val
end subroutine psb_e_set_sp_a2av_alg
function psb_cd_sizeof(desc) result(val)
implicit none
!....Parameters...
@@ -362,21 +384,6 @@ contains
integer(psb_lpk_) :: val
val = cd_large_threshold
end function psb_cd_get_large_threshold
subroutine psb_cd_set_maxspace(ith)
implicit none
integer(psb_ipk_), intent(in) :: ith
if (ith > 0) then
cd_maxspace = ith
end if
end subroutine psb_cd_set_maxspace
function psb_cd_get_maxspace() result(val)
implicit none
integer(psb_ipk_) :: val
val = cd_maxspace
end function psb_cd_get_maxspace
function psb_cd_is_large_size(m) result(val)
use psb_penv_mod
base/modules/desc/psb_gen_block_map_mod.F90
+10 -10
View File
@@ -127,7 +127,7 @@ module psb_gen_block_map_mod
#if defined(IPK4) && defined(LPK8)
private :: l_gen_block_search
#endif
interface gen_block_search
module procedure i_gen_block_search
#if defined(IPK4) && defined(LPK8)
@@ -373,7 +373,7 @@ contains
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i
integer(psb_lpk_) :: i
logical :: owned_
info = 0
@@ -431,7 +431,7 @@ contains
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im, i
integer(psb_lpk_) :: is, im, i
logical :: owned_
info = 0
@@ -806,7 +806,7 @@ contains
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, nv, is
integer(psb_lpk_) :: tidx, ip, lip
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: ictxt, iam, np
logical :: owned_
info = 0
@@ -922,7 +922,7 @@ contains
integer(psb_ipk_) :: i, nv, is, im
integer(psb_lpk_) :: tidx, ip, lip
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: ictxt, iam, np
logical :: owned_
info = 0
@@ -1527,7 +1527,7 @@ contains
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, nv, is, ix
integer(psb_lpk_) :: i, nv, is, ix
integer(psb_lpk_) :: ip, lip, lnxt
integer(psb_ipk_) :: nxt
@@ -1732,7 +1732,7 @@ contains
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, nv, is, ix, im
integer(psb_lpk_) :: i, nv, is, ix, im
integer(psb_lpk_) :: ip, lip, lnxt
integer(psb_ipk_) :: nxt
@@ -1964,11 +1964,11 @@ contains
use psb_error_mod
implicit none
class(psb_gen_block_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: nl
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
integer(psb_ipk_) :: i
integer(psb_lpk_) :: ntot
integer(psb_lpk_), allocatable :: vnl(:)
@@ -2030,7 +2030,7 @@ contains
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nhal, i
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: ictxt, iam, np
logical :: debug=.false.
info = 0
ictxt = idxmap%get_ctxt()
base/modules/desc/psb_glist_map_mod.f90
+2 -2
View File
@@ -96,11 +96,11 @@ contains
use psb_error_mod
implicit none
class(psb_glist_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vg(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
integer(psb_ipk_) :: nl
integer(psb_lpk_) :: i, n
base/modules/desc/psb_hash_map_mod.f90
+41 -38
View File
@@ -94,8 +94,8 @@ module psb_hash_map_mod
procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins
procedure, pass(idxmap) :: hash_cpy
generic, public :: assignment(=) => hash_cpy
!!$ procedure, pass(idxmap) :: hash_cpy
!!$ generic, public :: assignment(=) => hash_cpy
procedure, pass(idxmap) :: bld_g2l_map => hash_bld_g2l_map
end type psb_hash_map
@@ -805,11 +805,11 @@ contains
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
integer(psb_ipk_) :: i, nlu, nl, int_err(5)
integer(psb_lpk_) :: m, nrt
integer(psb_lpk_), allocatable :: vlu(:)
@@ -878,11 +878,11 @@ contains
use psb_error_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vg(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
integer(psb_ipk_) :: i, j, nl, int_err(5)
integer(psb_lpk_) :: n
integer(psb_lpk_), allocatable :: vlu(:)
@@ -938,12 +938,12 @@ contains
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vlu(:), ntot
integer(psb_ipk_), intent(in) :: nl
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
integer(psb_ipk_) :: i, j, lc2, nlu, m, nrt,int_err(5)
character(len=20), parameter :: name='hash_map_init_vlu'
@@ -1464,7 +1464,7 @@ contains
end if
select type (outmap)
type is (psb_hash_map)
type is (psb_hash_map)
call idxmap%psb_indx_map%cpy(outmap%psb_indx_map,info)
if (info == psb_success_) then
outmap%hashvsize = idxmap%hashvsize
@@ -1478,7 +1478,7 @@ contains
& call psb_safe_ab_cpy(idxmap%glb_lc,outmap%glb_lc,info)
if (info == psb_success_)&
& call psb_hash_copy(idxmap%hash,outmap%hash,info)
!!$ outmap = idxmap
class default
! This should be impossible
info = -1
@@ -1499,30 +1499,30 @@ contains
end subroutine hash_clone
subroutine hash_cpy(outmap,idxmap)
use psb_penv_mod
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(in) :: idxmap
type(psb_hash_map), intent(out) :: outmap
integer(psb_ipk_) :: info
info = psb_success_
outmap%psb_indx_map = idxmap%psb_indx_map
outmap%hashvsize = idxmap%hashvsize
outmap%hashvmask = idxmap%hashvmask
if (info == psb_success_)&
& call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info)
if (info == psb_success_)&
& call psb_safe_ab_cpy(idxmap%hashv,outmap%hashv,info)
if (info == psb_success_)&
& call psb_safe_ab_cpy(idxmap%glb_lc,outmap%glb_lc,info)
if (info == psb_success_)&
& call psb_hash_copy(idxmap%hash,outmap%hash,info)
end subroutine hash_cpy
!!$ subroutine hash_cpy(outmap,idxmap)
!!$ use psb_penv_mod
!!$ use psb_error_mod
!!$ use psb_realloc_mod
!!$ implicit none
!!$ class(psb_hash_map), intent(in) :: idxmap
!!$ type(psb_hash_map), intent(out) :: outmap
!!$ integer(psb_ipk_) :: info
!!$
!!$ info = psb_success_
!!$ call idxmap%psb_indx_map%cpy(outmap%psb_indx_map,info)
!!$ if (info == psb_success_) then
!!$ outmap%hashvsize = idxmap%hashvsize
!!$ outmap%hashvmask = idxmap%hashvmask
!!$ end if
!!$ if (info == psb_success_)&
!!$ & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info)
!!$ if (info == psb_success_)&
!!$ & call psb_safe_ab_cpy(idxmap%hashv,outmap%hashv,info)
!!$ if (info == psb_success_)&
!!$ & call psb_safe_ab_cpy(idxmap%glb_lc,outmap%glb_lc,info)
!!$ if (info == psb_success_)&
!!$ & call psb_hash_copy(idxmap%hash,outmap%hash,info)
!!$ end subroutine hash_cpy
subroutine hash_reinit(idxmap,info)
use psb_penv_mod
@@ -1534,8 +1534,8 @@ contains
integer(psb_ipk_) :: err_act, nr,nc,k, nl
integer(psb_lpk_) :: lk
integer(psb_lpk_) :: ntot
integer(psb_mpk_) :: ictxt, me, np
integer(psb_ipk_), allocatable :: lidx(:)
integer(psb_ipk_) :: ictxt, me, np
integer(psb_ipk_), allocatable :: lidx(:), tadj(:), th_own(:)
integer(psb_lpk_), allocatable :: gidx(:)
character(len=20) :: name='hash_reinit'
logical, parameter :: debug=.false.
@@ -1551,13 +1551,16 @@ contains
lidx = (/(k,k=1,nc)/)
gidx = (/(lk,lk=1,nc)/)
call idxmap%l2gip(gidx,info)
tadj = idxmap%get_p_adjcncy()
call idxmap%get_halo_owner(th_own,info)
call idxmap%free()
call hash_init_vlu(idxmap,ictxt,ntot,nr,gidx(1:nr),info)
if (nc>nr) then
call idxmap%g2lip_ins(gidx(nr+1:nc),info,lidx=lidx(nr+1:nc))
end if
call idxmap%set_p_adjcncy(tadj)
call idxmap%set_halo_owner(th_own,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
base/modules/desc/psb_hash_mod.F90
+9 -6
View File
@@ -64,8 +64,11 @@ module psb_hash_mod
end type psb_hash_type
integer(psb_ipk_), parameter :: HashDuplicate = 123, HashOK=0, HashOutOfMemory=-512,&
& HashFreeEntry = -1, HashNotFound = -256
integer(psb_ipk_), parameter :: HashOK=0
integer(psb_ipk_), parameter :: HashDuplicate = 123
integer(psb_ipk_), parameter :: HashOutOfMemory=-512
integer(psb_ipk_), parameter :: HashFreeEntry = -1
integer(psb_ipk_), parameter :: HashNotFound = -256
interface psb_hashval
#if defined(IPK4)
@@ -391,7 +394,7 @@ contains
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
hd = ior(hd,1_psb_ipk_)
end if
if (.not.allocated(hash%table)) then
info = HashOutOfMemory
@@ -451,7 +454,7 @@ contains
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
hd = ior(hd,1_psb_ipk_)
end if
if (.not.allocated(hash%table)) then
info = HashOutOfMemory
@@ -515,7 +518,7 @@ contains
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
hd = ior(hd,1_psb_ipk_)
end if
hash%nsrch = hash%nsrch + 1
@@ -555,7 +558,7 @@ contains
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
hd = ior(hd,1_psb_ipk_)
end if
hash%nsrch = hash%nsrch + 1
base/modules/desc/psb_indx_map_mod.f90
+104 -17
View File
@@ -29,7 +29,7 @@
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!!$
!
!
!
! package: psb_indx_map_mod
@@ -108,7 +108,7 @@ module psb_indx_map_mod
!> State of the map
integer(psb_ipk_) :: state = psb_desc_null_
!> Communication context
integer(psb_mpk_) :: ictxt = -1
integer(psb_ipk_) :: ictxt = -1
!> MPI communicator
integer(psb_mpk_) :: mpic = -1
!> Number of global rows
@@ -278,13 +278,14 @@ module psb_indx_map_mod
end interface
interface
subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info)
subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize)
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(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: samesize
end subroutine psi_a2a_fnd_owner
end interface
@@ -311,6 +312,25 @@ module psb_indx_map_mod
end subroutine psi_graph_fnd_owner
end interface
interface psb_cd_set_maxspace
module procedure psb_cd_set_maxspace
end interface psb_cd_set_maxspace
interface psb_cd_get_maxspace
module procedure psb_cd_get_maxspace
end interface psb_cd_get_maxspace
interface psb_cd_set_samplesize
module procedure psb_cd_set_samplesize
end interface psb_cd_set_samplesize
interface psb_cd_get_samplesize
module procedure psb_cd_get_samplesize
end interface psb_cd_get_samplesize
integer(psb_ipk_), private, save :: cd_maxspace = -1
integer(psb_ipk_), private, save :: samplesize = 32
integer, parameter :: psi_symm_flag_norv_ = 0
integer, parameter :: psi_symm_flag_inrv_ = 1
interface psi_symm_dep_list
@@ -331,9 +351,69 @@ module psb_indx_map_mod
end subroutine psi_symm_dep_list_norv
end interface psi_symm_dep_list
integer(psb_mpk_), parameter :: psi_adj_fnd_irecv_ = 0
integer(psb_mpk_), parameter :: psi_adj_fnd_a2av_ = 1
integer(psb_mpk_), parameter :: psi_adj_fnd_pbrcv_ = 2
integer(psb_mpk_), parameter :: psi_adj_alg_max_ = psi_adj_fnd_pbrcv_
integer(psb_mpk_), save :: psi_adj_alg = psi_adj_fnd_irecv_
contains
subroutine psi_set_adj_alg(ialg)
integer(psb_mpk_), intent(in) :: ialg
if ((ialg >=0) .and. (ialg <= psi_adj_alg_max_))&
& psi_adj_alg = ialg
end subroutine psi_set_adj_alg
function psi_get_adj_alg() result(val)
integer(psb_mpk_) :: val
val = psi_adj_alg
end function psi_get_adj_alg
function psi_get_adj_alg_fmt() result(val)
character(len=20) :: val
select case(psi_adj_alg)
case(psi_adj_fnd_a2av_)
val = 'MPI_A2AV'
case(psi_adj_fnd_irecv_)
val = 'MPI_ISEND/IRECV'
case(psi_adj_fnd_pbrcv_)
val = 'PSB_SND/RCV'
case default
val = 'Unknown ?'
end select
end function psi_get_adj_alg_fmt
subroutine psb_cd_set_maxspace(ith)
implicit none
integer(psb_ipk_), intent(in) :: ith
if (ith > 0) then
cd_maxspace = ith
end if
end subroutine psb_cd_set_maxspace
function psb_cd_get_maxspace() result(val)
implicit none
integer(psb_ipk_) :: val
val = cd_maxspace
end function psb_cd_get_maxspace
subroutine psb_cd_set_samplesize(ith)
implicit none
integer(psb_ipk_), intent(in) :: ith
if (ith > 0) then
samplesize = ith
end if
end subroutine psb_cd_set_samplesize
function psb_cd_get_samplesize() result(val)
implicit none
integer(psb_ipk_) :: val
val = samplesize
end function psb_cd_get_samplesize
!>
!! \memberof psb_indx_map
!! \brief Print a descriptive name
@@ -407,7 +487,7 @@ contains
function base_get_ctxt(idxmap) result(val)
implicit none
class(psb_indx_map), intent(in) :: idxmap
integer(psb_mpk_) :: val
integer(psb_ipk_) :: val
val = idxmap%ictxt
@@ -435,7 +515,7 @@ contains
subroutine base_set_ctxt(idxmap,val)
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: val
integer(psb_ipk_), intent(in) :: val
idxmap%ictxt = val
end subroutine base_set_ctxt
@@ -1268,7 +1348,7 @@ contains
use psb_error_mod
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
@@ -1390,7 +1470,7 @@ contains
integer(psb_ipk_), intent(in) :: v(:)
integer(psb_ipk_), intent(out) :: info
!
integer(psb_mpk_) :: me, np
integer(psb_ipk_) :: me, np
integer(psb_ipk_) :: i, j, nr, nc, nh
call psb_info(idxmap%ictxt,me,np)
@@ -1406,6 +1486,7 @@ contains
end subroutine base_set_halo_owner
subroutine base_get_halo_owner(idxmap,v,info)
use psb_realloc_mod
use psb_penv_mod
use psb_error_mod
implicit none
@@ -1414,13 +1495,15 @@ contains
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: nh
nh = min(size(v),size(idxmap%halo_owner))
v(1:nh) = idxmap%halo_owner(1:nh)
nh = size(idxmap%halo_owner)
!v = idxmap%halo_owner(1:nh)
call psb_safe_ab_cpy(idxmap%halo_owner,v,info)
end subroutine base_get_halo_owner
subroutine base_fnd_halo_owner_s(idxmap,xin,xout,info)
use psb_penv_mod
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: xin
@@ -1430,16 +1513,17 @@ contains
integer(psb_ipk_) :: i, j, nr, nc, nh
nr = idxmap%local_rows
nc = idxmap%local_cols
nc = min(idxmap%local_cols, (nr+psb_size(idxmap%halo_owner)))
xout = -1
if (.not.allocated(idxmap%halo_owner)) then
!write(0,*) 'Halo_owner not allocated!', nr, nc, xin
return
end if
if ((nr<xin).and.(xin <= nc)) then
if (size(idxmap%halo_owner)<(xin-nr)) then
!write(0,*) 'Halo_owner bad size',xin,nr,xin-nr,size(idxmap%halo_owner)
return
end if
!!$ if (size(idxmap%halo_owner)<(xin-nr)) then
!!$ !write(0,*) 'Halo_owner bad size',xin,nr,xin-nr,size(idxmap%halo_owner)
!!$ return
!!$ end if
xout = idxmap%halo_owner(xin-nr)
end if
@@ -1448,6 +1532,7 @@ contains
subroutine base_fnd_halo_owner_v(idxmap,xin,xout,info)
use psb_penv_mod
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_indx_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: xin(:)
@@ -1456,13 +1541,15 @@ contains
integer(psb_ipk_) :: i, j, nr, nc, nh, sz
nr = idxmap%local_rows
nc = idxmap%local_cols
nc = min(idxmap%local_cols, (nr+psb_size(idxmap%halo_owner)))
sz = min(size(xin),size(xout))
xout = -1
do i = 1, sz
if ((nr<xin(i)).and.(xin(i) <= nc)) xout = idxmap%halo_owner(xin(i)-nr)
xout(i) = -1
if ((nr<xin(i)).and.(xin(i) <= nc)) xout(i) = idxmap%halo_owner(xin(i)-nr)
end do
do i=sz+1,size(xout)
xout(i) = -1
end do
end subroutine base_fnd_halo_owner_v
end module psb_indx_map_mod
base/modules/desc/psb_list_map_mod.f90
+4 -4
View File
@@ -1044,13 +1044,13 @@ contains
use psb_error_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_lpk_) :: nl
integer(psb_lpk_), allocatable :: lvl(:)
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
info = 0
call psb_info(ictxt,iam,np)
@@ -1078,12 +1078,12 @@ contains
use psb_error_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_lpk_) :: i, ix, nl, n, nrt
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
info = 0
call psb_info(ictxt,iam,np)
base/modules/desc/psb_repl_map_mod.f90
+2 -2
View File
@@ -726,10 +726,10 @@ contains
implicit none
class(psb_repl_map), intent(inout) :: idxmap
integer(psb_lpk_), intent(in) :: nl
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: iam, np
info = 0
call psb_info(ictxt,iam,np)
base/modules/penv/psi_c_collective_mod.F90
+237 -22
View File
@@ -31,6 +31,7 @@
!
module psi_c_collective_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_sum
@@ -62,7 +63,13 @@ module psi_c_collective_mod
module procedure psb_cexscan_sums, psb_cexscan_sumv
end interface psb_exscan_sum
interface psb_simple_a2av
module procedure psb_c_simple_a2av
end interface psb_simple_a2av
interface psb_simple_triad_a2av
module procedure psb_c_e_simple_triad_a2av, psb_c_m_simple_triad_a2av
end interface psb_simple_triad_a2av
contains
@@ -764,16 +771,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat
complex(psb_spk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_scan(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_scan(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,icomm,minfo)
dat = dat_
#endif
end subroutine psb_cscan_sums
@@ -787,16 +795,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat
complex(psb_spk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: icomm, minfo
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_exscan(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_exscan(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,icomm,minfo)
dat = dat_
#else
dat = czero
@@ -812,20 +821,21 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
complex(psb_spk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,minfo)
#endif
end subroutine psb_cscan_sumv
@@ -838,23 +848,228 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
complex(psb_spk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,minfo)
#else
dat = czero
#endif
end subroutine psb_cexscan_sumv
subroutine psb_c_simple_a2av(valsnd,sdsz,bsdindx,&
& valrcv,rvsz,brvindx,ictxt,info)
use psi_c_p2p_mod
implicit none
complex(psb_spk_), intent(in) :: valsnd(:)
complex(psb_spk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz
call psb_info(ictxt,iam,np)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
idx = bsdindx(ip+1)
call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip)
end if
end do
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
idx = brvindx(ip+1)
call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip)
end if
end do
end subroutine psb_c_simple_a2av
subroutine psb_c_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
complex(psb_spk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:)
complex(psb_spk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_complex_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_c_spk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_complex_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_c_spk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_c_m_simple_triad_a2av
subroutine psb_c_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
complex(psb_spk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:)
complex(psb_spk_), intent(out) :: valrcv(:)
integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_complex_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_c_spk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_complex_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_c_e_simple_triad_a2av
end module psi_c_collective_mod
base/modules/penv/psi_d_collective_mod.F90
+237 -22
View File
@@ -31,6 +31,7 @@
!
module psi_d_collective_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_max
module procedure psb_dmaxs, psb_dmaxv, psb_dmaxm, &
@@ -76,7 +77,13 @@ module psi_d_collective_mod
module procedure psb_dexscan_sums, psb_dexscan_sumv
end interface psb_exscan_sum
interface psb_simple_a2av
module procedure psb_d_simple_a2av
end interface psb_simple_a2av
interface psb_simple_triad_a2av
module procedure psb_d_e_simple_triad_a2av, psb_d_m_simple_triad_a2av
end interface psb_simple_triad_a2av
contains
@@ -1255,16 +1262,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat
real(psb_dpk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_scan(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_scan(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
dat = dat_
#endif
end subroutine psb_dscan_sums
@@ -1278,16 +1286,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat
real(psb_dpk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: icomm, minfo
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_exscan(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_exscan(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
dat = dat_
#else
dat = dzero
@@ -1303,20 +1312,21 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
real(psb_dpk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
#endif
end subroutine psb_dscan_sumv
@@ -1329,23 +1339,228 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
real(psb_dpk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,minfo)
#else
dat = dzero
#endif
end subroutine psb_dexscan_sumv
subroutine psb_d_simple_a2av(valsnd,sdsz,bsdindx,&
& valrcv,rvsz,brvindx,ictxt,info)
use psi_d_p2p_mod
implicit none
real(psb_dpk_), intent(in) :: valsnd(:)
real(psb_dpk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz
call psb_info(ictxt,iam,np)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
idx = bsdindx(ip+1)
call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip)
end if
end do
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
idx = brvindx(ip+1)
call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip)
end if
end do
end subroutine psb_d_simple_a2av
subroutine psb_d_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
real(psb_dpk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:)
real(psb_dpk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_double_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_double_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_d_m_simple_triad_a2av
subroutine psb_d_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
real(psb_dpk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:)
real(psb_dpk_), intent(out) :: valrcv(:)
integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_double_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_double_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_d_e_simple_triad_a2av
end module psi_d_collective_mod
base/modules/penv/psi_e_collective_mod.F90
+237 -22
View File
@@ -31,6 +31,7 @@
!
module psi_e_collective_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_max
module procedure psb_emaxs, psb_emaxv, psb_emaxm, &
@@ -72,7 +73,13 @@ module psi_e_collective_mod
module procedure psb_eexscan_sums, psb_eexscan_sumv
end interface psb_exscan_sum
interface psb_simple_a2av
module procedure psb_e_simple_a2av
end interface psb_simple_a2av
interface psb_simple_triad_a2av
module procedure psb_e_e_simple_triad_a2av, psb_e_m_simple_triad_a2av
end interface psb_simple_triad_a2av
contains
@@ -1132,16 +1139,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_epk_), intent(inout) :: dat
integer(psb_epk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_scan(dat,dat_,1,psb_mpi_epk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_scan(dat,dat_,1,psb_mpi_epk_,mpi_sum,icomm,minfo)
dat = dat_
#endif
end subroutine psb_escan_sums
@@ -1155,16 +1163,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_epk_), intent(inout) :: dat
integer(psb_epk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: icomm, minfo
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_exscan(dat,dat_,1,psb_mpi_epk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_exscan(dat,dat_,1,psb_mpi_epk_,mpi_sum,icomm,minfo)
dat = dat_
#else
dat = ezero
@@ -1180,20 +1189,21 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_epk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
integer(psb_epk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,icomm,minfo)
#endif
end subroutine psb_escan_sumv
@@ -1206,23 +1216,228 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_epk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
integer(psb_epk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,icomm,minfo)
#else
dat = ezero
#endif
end subroutine psb_eexscan_sumv
subroutine psb_e_simple_a2av(valsnd,sdsz,bsdindx,&
& valrcv,rvsz,brvindx,ictxt,info)
use psi_e_p2p_mod
implicit none
integer(psb_epk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz
call psb_info(ictxt,iam,np)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
idx = bsdindx(ip+1)
call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip)
end if
end do
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
idx = brvindx(ip+1)
call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip)
end if
end do
end subroutine psb_e_simple_a2av
subroutine psb_e_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_epk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:)
integer(psb_epk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_int8_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_int8_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_e_m_simple_triad_a2av
subroutine psb_e_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_epk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:)
integer(psb_epk_), intent(out) :: valrcv(:)
integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_int8_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_int8_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_e_e_simple_triad_a2av
end module psi_e_collective_mod
base/modules/penv/psi_i2_collective_mod.F90
+1443
View File
File diff suppressed because it is too large Load Diff
base/modules/penv/psi_i2_p2p_mod.F90
+307
View File
@@ -0,0 +1,307 @@
!
! 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.
!
!
module psi_i2_p2p_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_snd
module procedure psb_i2snds, psb_i2sndv, psb_i2sndm, &
& psb_i2snds_ec, psb_i2sndv_ec, psb_i2sndm_ec
end interface
interface psb_rcv
module procedure psb_i2rcvs, psb_i2rcvv, psb_i2rcvm, &
& psb_i2rcvs_ec, psb_i2rcvv_ec, psb_i2rcvm_ec
end interface
contains
subroutine psb_i2snds(ictxt,dat,dst)
use psi_comm_buffers_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(in) :: dat
integer(psb_mpk_), intent(in) :: dst
integer(psb_i2pk_), allocatable :: dat_(:)
integer(psb_mpk_) :: info
#if defined(SERIAL_MPI)
! do nothing
#else
allocate(dat_(1), stat=info)
dat_(1) = dat
call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue)
#endif
end subroutine psb_i2snds
subroutine psb_i2sndv(ictxt,dat,dst)
use psi_comm_buffers_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(in) :: dat(:)
integer(psb_mpk_), intent(in) :: dst
integer(psb_i2pk_), allocatable :: dat_(:)
integer(psb_mpk_) :: info
#if defined(SERIAL_MPI)
#else
allocate(dat_(size(dat)), stat=info)
dat_(:) = dat(:)
call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue)
#endif
end subroutine psb_i2sndv
subroutine psb_i2sndm(ictxt,dat,dst,m)
use psi_comm_buffers_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(in) :: dat(:,:)
integer(psb_mpk_), intent(in) :: dst
integer(psb_ipk_), intent(in), optional :: m
integer(psb_i2pk_), allocatable :: dat_(:)
integer(psb_ipk_) :: i,j,k,m_,n_
integer(psb_mpk_) :: info
#if defined(SERIAL_MPI)
#else
if (present(m)) then
m_ = m
else
m_ = size(dat,1)
end if
n_ = size(dat,2)
allocate(dat_(m_*n_), stat=info)
k=1
do j=1,n_
do i=1, m_
dat_(k) = dat(i,j)
k = k + 1
end do
end do
call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue)
#endif
end subroutine psb_i2sndm
subroutine psb_i2rcvs(ictxt,dat,src)
use psi_comm_buffers_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(out) :: dat
integer(psb_mpk_), intent(in) :: src
integer(psb_mpk_) :: info
integer(psb_mpk_) :: status(mpi_status_size)
#if defined(SERIAL_MPI)
! do nothing
#else
call mpi_recv(dat,1,psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info)
call psb_test_nodes(psb_mesg_queue)
#endif
end subroutine psb_i2rcvs
subroutine psb_i2rcvv(ictxt,dat,src)
use psi_comm_buffers_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(out) :: dat(:)
integer(psb_mpk_), intent(in) :: src
integer(psb_i2pk_), allocatable :: dat_(:)
integer(psb_mpk_) :: info
integer(psb_mpk_) :: status(mpi_status_size)
#if defined(SERIAL_MPI)
#else
call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info)
call psb_test_nodes(psb_mesg_queue)
#endif
end subroutine psb_i2rcvv
subroutine psb_i2rcvm(ictxt,dat,src,m)
use psi_comm_buffers_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(out) :: dat(:,:)
integer(psb_mpk_), intent(in) :: src
integer(psb_ipk_), intent(in), optional :: m
integer(psb_i2pk_), allocatable :: dat_(:)
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
integer(psb_mpk_) :: i,j,k
integer(psb_mpk_) :: status(mpi_status_size)
#if defined(SERIAL_MPI)
! What should we do here??
#else
if (present(m)) then
m_ = m
ld = size(dat,1)
n_ = size(dat,2)
call mpi_type_vector(n_,m_,ld,psb_mpi_i2pk_,mp_rcv_type,info)
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
& psb_int2_tag,ictxt,status,info)
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
else
call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info)
end if
if (info /= mpi_success) then
write(psb_err_unit,*) 'Error in psb_recv', info
end if
call psb_test_nodes(psb_mesg_queue)
#endif
end subroutine psb_i2rcvm
subroutine psb_i2snds_ec(ictxt,dat,dst)
integer(psb_epk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(in) :: dat
integer(psb_epk_), intent(in) :: dst
integer(psb_mpk_) :: iictxt, idst
iictxt = ictxt
idst = dst
call psb_snd(iictxt, dat, idst)
end subroutine psb_i2snds_ec
subroutine psb_i2sndv_ec(ictxt,dat,dst)
integer(psb_epk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(in) :: dat(:)
integer(psb_epk_), intent(in) :: dst
integer(psb_mpk_) :: iictxt, idst
iictxt = ictxt
idst = dst
call psb_snd(iictxt, dat, idst)
end subroutine psb_i2sndv_ec
subroutine psb_i2sndm_ec(ictxt,dat,dst,m)
integer(psb_epk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(in) :: dat(:,:)
integer(psb_epk_), intent(in) :: dst
integer(psb_mpk_) :: iictxt, idst
iictxt = ictxt
idst = dst
call psb_snd(iictxt, dat, idst)
end subroutine psb_i2sndm_ec
subroutine psb_i2rcvs_ec(ictxt,dat,src)
integer(psb_epk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(out) :: dat
integer(psb_epk_), intent(in) :: src
integer(psb_mpk_) :: iictxt, isrc
iictxt = ictxt
isrc = src
call psb_rcv(iictxt, dat, isrc)
end subroutine psb_i2rcvs_ec
subroutine psb_i2rcvv_ec(ictxt,dat,src)
integer(psb_epk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(out) :: dat(:)
integer(psb_epk_), intent(in) :: src
integer(psb_mpk_) :: iictxt, isrc
iictxt = ictxt
isrc = src
call psb_rcv(iictxt, dat, isrc)
end subroutine psb_i2rcvv_ec
subroutine psb_i2rcvm_ec(ictxt,dat,src,m)
integer(psb_epk_), intent(in) :: ictxt
integer(psb_i2pk_), intent(out) :: dat(:,:)
integer(psb_epk_), intent(in) :: src
integer(psb_mpk_) :: iictxt, isrc
iictxt = ictxt
isrc = src
call psb_rcv(iictxt, dat, isrc)
end subroutine psb_i2rcvm_ec
end module psi_i2_p2p_mod
base/modules/penv/psi_m_collective_mod.F90
+237 -22
View File
@@ -31,6 +31,7 @@
!
module psi_m_collective_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_max
module procedure psb_mmaxs, psb_mmaxv, psb_mmaxm, &
@@ -72,7 +73,13 @@ module psi_m_collective_mod
module procedure psb_mexscan_sums, psb_mexscan_sumv
end interface psb_exscan_sum
interface psb_simple_a2av
module procedure psb_m_simple_a2av
end interface psb_simple_a2av
interface psb_simple_triad_a2av
module procedure psb_m_e_simple_triad_a2av, psb_m_m_simple_triad_a2av
end interface psb_simple_triad_a2av
contains
@@ -1132,16 +1139,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_mpk_), intent(inout) :: dat
integer(psb_mpk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_scan(dat,dat_,1,psb_mpi_mpk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_scan(dat,dat_,1,psb_mpi_mpk_,mpi_sum,icomm,minfo)
dat = dat_
#endif
end subroutine psb_mscan_sums
@@ -1155,16 +1163,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_mpk_), intent(inout) :: dat
integer(psb_mpk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: icomm, minfo
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_exscan(dat,dat_,1,psb_mpi_mpk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_exscan(dat,dat_,1,psb_mpi_mpk_,mpi_sum,icomm,minfo)
dat = dat_
#else
dat = mzero
@@ -1180,20 +1189,21 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_mpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
integer(psb_mpk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,icomm,minfo)
#endif
end subroutine psb_mscan_sumv
@@ -1206,23 +1216,228 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_mpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
integer(psb_mpk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,icomm,minfo)
#else
dat = mzero
#endif
end subroutine psb_mexscan_sumv
subroutine psb_m_simple_a2av(valsnd,sdsz,bsdindx,&
& valrcv,rvsz,brvindx,ictxt,info)
use psi_m_p2p_mod
implicit none
integer(psb_mpk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz
call psb_info(ictxt,iam,np)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
idx = bsdindx(ip+1)
call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip)
end if
end do
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
idx = brvindx(ip+1)
call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip)
end if
end do
end subroutine psb_m_simple_a2av
subroutine psb_m_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:)
integer(psb_mpk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_int4_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_int4_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_m_m_simple_triad_a2av
subroutine psb_m_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:)
integer(psb_mpk_), intent(out) :: valrcv(:)
integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_int4_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_int4_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_m_e_simple_triad_a2av
end module psi_m_collective_mod
base/modules/penv/psi_penv_mod.F90
+29 -6
View File
@@ -75,8 +75,15 @@ module psi_penv_mod
interface psb_wtime
module procedure psb_wtime
end interface
end interface psb_wtime
interface psb_get_mpi_comm
module procedure psb_m_get_mpi_comm, psb_e_get_mpi_comm
end interface psb_get_mpi_comm
interface psb_get_mpi_rank
module procedure psb_m_get_mpi_rank, psb_e_get_mpi_rank
end interface psb_get_mpi_rank
#if defined(SERIAL_MPI)
integer(psb_mpk_), private, save :: nctxt=0
@@ -563,17 +570,33 @@ contains
end subroutine psb_info_mpik
function psb_get_mpi_comm(ictxt) result(comm)
function psb_m_get_mpi_comm(ictxt) result(comm)
integer(psb_mpk_) :: ictxt, comm
comm = ictxt
end function psb_get_mpi_comm
end function psb_m_get_mpi_comm
function psb_get_mpi_rank(ictxt,id) result(rank)
integer(psb_mpk_) :: rank,ictxt,id
function psb_e_get_mpi_comm(ictxt) result(comm)
integer(psb_epk_) :: ictxt
integer(psb_mpk_) :: comm
comm = ictxt
end function psb_e_get_mpi_comm
function psb_m_get_mpi_rank(ictxt,id) result(rank)
integer(psb_mpk_) :: rank
integer(psb_mpk_) :: ictxt,id
rank = id
end function psb_get_mpi_rank
end function psb_m_get_mpi_rank
function psb_e_get_mpi_rank(ictxt,id) result(rank)
integer(psb_mpk_) :: rank
integer(psb_epk_) :: ictxt,id
rank = id
end function psb_e_get_mpi_rank
subroutine psb_get_mpicomm(ictxt,comm)
base/modules/penv/psi_s_collective_mod.F90
+237 -22
View File
@@ -31,6 +31,7 @@
!
module psi_s_collective_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_max
module procedure psb_smaxs, psb_smaxv, psb_smaxm, &
@@ -76,7 +77,13 @@ module psi_s_collective_mod
module procedure psb_sexscan_sums, psb_sexscan_sumv
end interface psb_exscan_sum
interface psb_simple_a2av
module procedure psb_s_simple_a2av
end interface psb_simple_a2av
interface psb_simple_triad_a2av
module procedure psb_s_e_simple_triad_a2av, psb_s_m_simple_triad_a2av
end interface psb_simple_triad_a2av
contains
@@ -1255,16 +1262,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat
real(psb_spk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_scan(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_scan(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,icomm,minfo)
dat = dat_
#endif
end subroutine psb_sscan_sums
@@ -1278,16 +1286,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat
real(psb_spk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: icomm, minfo
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_exscan(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_exscan(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,icomm,minfo)
dat = dat_
#else
dat = szero
@@ -1303,20 +1312,21 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
real(psb_spk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,minfo)
#endif
end subroutine psb_sscan_sumv
@@ -1329,23 +1339,228 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
real(psb_spk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,minfo)
#else
dat = szero
#endif
end subroutine psb_sexscan_sumv
subroutine psb_s_simple_a2av(valsnd,sdsz,bsdindx,&
& valrcv,rvsz,brvindx,ictxt,info)
use psi_s_p2p_mod
implicit none
real(psb_spk_), intent(in) :: valsnd(:)
real(psb_spk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz
call psb_info(ictxt,iam,np)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
idx = bsdindx(ip+1)
call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip)
end if
end do
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
idx = brvindx(ip+1)
call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip)
end if
end do
end subroutine psb_s_simple_a2av
subroutine psb_s_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
real(psb_spk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:)
real(psb_spk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_real_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_r_spk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_real_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_spk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_s_m_simple_triad_a2av
subroutine psb_s_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
real(psb_spk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:)
real(psb_spk_), intent(out) :: valrcv(:)
integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_real_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_r_spk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_real_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_s_e_simple_triad_a2av
end module psi_s_collective_mod
base/modules/penv/psi_z_collective_mod.F90
+237 -22
View File
@@ -31,6 +31,7 @@
!
module psi_z_collective_mod
use psi_penv_mod
use psi_comm_buffers_mod
interface psb_sum
@@ -62,7 +63,13 @@ module psi_z_collective_mod
module procedure psb_zexscan_sums, psb_zexscan_sumv
end interface psb_exscan_sum
interface psb_simple_a2av
module procedure psb_z_simple_a2av
end interface psb_simple_a2av
interface psb_simple_triad_a2av
module procedure psb_z_e_simple_triad_a2av, psb_z_m_simple_triad_a2av
end interface psb_simple_triad_a2av
contains
@@ -764,16 +771,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat
complex(psb_dpk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_scan(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_scan(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
dat = dat_
#endif
end subroutine psb_zscan_sums
@@ -787,16 +795,17 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat
complex(psb_dpk_) :: dat_
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: icomm, minfo
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call mpi_exscan(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,ictxt,info)
icomm = psb_get_mpi_comm(ictxt)
call mpi_exscan(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
dat = dat_
#else
dat = zzero
@@ -812,20 +821,21 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
complex(psb_dpk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_scan(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
#endif
end subroutine psb_zscan_sumv
@@ -838,23 +848,228 @@ contains
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat(:)
integer(psb_mpk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: root
integer(psb_mpk_) :: root_
complex(psb_dpk_), allocatable :: dat_(:)
integer(psb_mpk_) :: iam, np, info
integer(psb_ipk_) :: iinfo
integer(psb_ipk_) :: iam, np, info
integer(psb_mpk_) :: minfo, icomm
#if !defined(SERIAL_MPI)
call psb_info(ictxt,iam,np)
call psb_realloc(size(dat),dat_,iinfo)
icomm = psb_get_mpi_comm(ictxt)
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (iinfo == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info)
if (info == psb_success_) &
& call mpi_exscan(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,minfo)
#else
dat = zzero
#endif
end subroutine psb_zexscan_sumv
subroutine psb_z_simple_a2av(valsnd,sdsz,bsdindx,&
& valrcv,rvsz,brvindx,ictxt,info)
use psi_z_p2p_mod
implicit none
complex(psb_dpk_), intent(in) :: valsnd(:)
complex(psb_dpk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz
call psb_info(ictxt,iam,np)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
idx = bsdindx(ip+1)
call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip)
end if
end do
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
idx = brvindx(ip+1)
call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip)
end if
end do
end subroutine psb_z_simple_a2av
subroutine psb_z_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
complex(psb_dpk_), intent(in) :: valsnd(:)
integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:)
complex(psb_dpk_), intent(out) :: valrcv(:)
integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_dcomplex_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_c_dpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_dcomplex_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_c_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_mpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_z_m_simple_triad_a2av
subroutine psb_z_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
& valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info)
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
complex(psb_dpk_), intent(in) :: valsnd(:)
integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:)
complex(psb_dpk_), intent(out) :: valrcv(:)
integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:)
integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:)
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info
!Local variables
integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm
integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:)
call psb_info(ictxt,iam,np)
icomm = psb_get_mpi_comm(ictxt)
if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz))<np) then
info = psb_err_internal_error_
return
end if
allocate(prcid(np),rvhd(np,3))
prcid = -1
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = brvindx(ip+1)
p2ptag = psb_dcomplex_tag
call mpi_irecv(valrcv(idx+1:idx+sz),sz,&
& psb_mpi_c_dpk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,1),iret)
p2ptag = psb_int_swap_tag
call mpi_irecv(iarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,2),iret)
call mpi_irecv(jarcv(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,rvhd(ip+1,3),iret)
end if
Enddo
do ip = 0, np-1
sz = sdsz(ip+1)
if (sz > 0) then
if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip)
idx = bsdindx(ip+1)
p2ptag = psb_dcomplex_tag
call mpi_send(valsnd(idx+1:idx+sz),sz,&
& psb_mpi_r_dpk_,prcid(ip+1),&
& p2ptag, icomm,iret)
p2ptag = psb_int_swap_tag
call mpi_send(iasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
call mpi_send(jasnd(idx+1:idx+sz),sz,&
& psb_mpi_epk_,prcid(ip+1),&
& p2ptag, icomm,iret)
end if
Enddo
do ip = 0, np-1
sz = rvsz(ip+1)
if (sz > 0) then
call mpi_wait(rvhd(ip+1,1),p2pstat,iret)
call mpi_wait(rvhd(ip+1,2),p2pstat,iret)
call mpi_wait(rvhd(ip+1,3),p2pstat,iret)
end if
Enddo
end subroutine psb_z_e_simple_triad_a2av
end module psi_z_collective_mod
base/modules/psb_const_mod.F90
+9 -7
View File
@@ -103,9 +103,9 @@ module psb_const_mod
integer(psb_ipk_), save :: psb_sizeof_sp
integer(psb_ipk_), save :: psb_sizeof_dp
integer(psb_ipk_), save :: psb_sizeof_i2p
integer(psb_ipk_), save :: psb_sizeof_mp = 4
integer(psb_ipk_), save :: psb_sizeof_ep = 8
integer(psb_ipk_), save :: psb_sizeof_i2p = 2
integer(psb_ipk_), save :: psb_sizeof_mp = 4
integer(psb_ipk_), save :: psb_sizeof_ep = 8
#if defined(IPK4) && defined(LPK4)
integer(psb_ipk_), save :: psb_sizeof_ip = 4
@@ -145,13 +145,15 @@ module psb_const_mod
! Handy & miscellaneous constants
!
integer(psb_epk_), parameter :: ezero=0, eone=1
integer(psb_epk_), parameter :: etwo=2, ethree=3,emone=-1
integer(psb_epk_), parameter :: etwo=2, ethree=3, emone=-1
integer(psb_mpk_), parameter :: mzero=0, mone=1
integer(psb_mpk_), parameter :: mtwo=2, mthree=3,mmone=-1
integer(psb_mpk_), parameter :: mtwo=2, mthree=3, mmone=-1
integer(psb_lpk_), parameter :: lzero=0, lone=1
integer(psb_lpk_), parameter :: ltwo=2, lthree=3,lmone=-1
integer(psb_lpk_), parameter :: ltwo=2, lthree=3, lmone=-1
integer(psb_ipk_), parameter :: izero=0, ione=1
integer(psb_ipk_), parameter :: itwo=2, ithree=3,imone=-1
integer(psb_ipk_), parameter :: itwo=2, ithree=3, imone=-1
integer(psb_i2pk_), parameter :: i2zero=0, i2one=1
integer(psb_i2pk_), parameter :: i2two=2, i2three=3, i2mone=-1
integer(psb_ipk_), parameter :: psb_root_=0
real(psb_spk_), parameter :: szero=0.0_psb_spk_, sone=1.0_psb_spk_
base/modules/psb_timers_mod.f90
+1 -1
View File
@@ -56,7 +56,7 @@ module psb_timers_mod
! The data itself
type psb_string_item
character(len=:), allocatable :: data
character(len=40) :: data
end type psb_string_item
integer(psb_ipk_), allocatable :: nsamples(:)
real(psb_dpk_), allocatable :: timers(:,:)
base/modules/serial/psb_base_mat_mod.F90
+407 -408
View File
File diff suppressed because it is too large Load Diff
base/modules/serial/psb_c_base_mat_mod.F90
+160 -2
View File
@@ -167,6 +167,7 @@ module psb_c_base_mat_mod
procedure, pass(a) :: sizeof => c_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_c_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_c_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_c_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_c_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_c_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_c_cp_coo_to_fmt
@@ -191,6 +192,7 @@ module psb_c_base_mat_mod
procedure, pass(a) :: fix => psb_c_fix_coo
procedure, pass(a) :: trim => psb_c_coo_trim
procedure, pass(a) :: clean_zeros => psb_c_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_c_coo_clean_negidx
procedure, pass(a) :: print => psb_c_coo_print
procedure, pass(a) :: free => c_coo_free
procedure, pass(a) :: mold => psb_c_coo_mold
@@ -360,6 +362,7 @@ module psb_c_base_mat_mod
procedure, pass(a) :: sizeof => lc_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_lc_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_lc_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_lc_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_lc_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_lc_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_lc_cp_coo_to_fmt
@@ -380,6 +383,7 @@ module psb_c_base_mat_mod
procedure, pass(a) :: fix => psb_lc_fix_coo
procedure, pass(a) :: trim => psb_lc_coo_trim
procedure, pass(a) :: clean_zeros => psb_lc_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_lc_coo_clean_negidx
procedure, pass(a) :: print => psb_lc_coo_print
procedure, pass(a) :: free => lc_coo_free
procedure, pass(a) :: mold => psb_lc_coo_mold
@@ -1678,6 +1682,17 @@ module psb_c_base_mat_mod
class(psb_c_coo_sparse_mat), intent(inout) :: a
end subroutine psb_c_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_c_coo_sparse_mat
!
interface
subroutine psb_c_coo_ensure_size(nz,a)
import
integer(psb_ipk_), intent(in) :: nz
class(psb_c_coo_sparse_mat), intent(inout) :: a
end subroutine psb_c_coo_ensure_size
end interface
!
!>
@@ -1715,6 +1730,46 @@ module psb_c_base_mat_mod
end subroutine psb_c_coo_clean_zeros
end interface
!
!>
!! \memberof psb_c_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_c_coo_clean_negidx(a,info)
import
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_coo_clean_negidx
end interface
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
complex(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
!
!>
!! \memberof psb_c_coo_sparse_mat
@@ -1759,9 +1814,9 @@ module psb_c_base_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_c_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_c_coo_print
end interface
@@ -3279,6 +3334,17 @@ module psb_c_base_mat_mod
class(psb_lc_coo_sparse_mat), intent(inout) :: a
end subroutine psb_lc_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_lc_coo_sparse_mat
!
interface
subroutine psb_lc_coo_ensure_size(nz,a)
import
integer(psb_lpk_), intent(in) :: nz
class(psb_lc_coo_sparse_mat), intent(inout) :: a
end subroutine psb_lc_coo_ensure_size
end interface
!
!>
@@ -3316,6 +3382,46 @@ module psb_c_base_mat_mod
end subroutine psb_lc_coo_clean_zeros
end interface
!
!>
!! \memberof psb_lc_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_lc_coo_clean_negidx(a,info)
import
class(psb_lc_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lc_coo_clean_negidx
end interface
#if defined(IPK4) && defined(LPK8)
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
complex(psb_spk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lc_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
#endif
!
!>
!! \memberof psb_lc_coo_sparse_mat
@@ -3674,6 +3780,8 @@ module psb_c_base_mat_mod
end subroutine psb_lc_coo_scals
end interface
public :: psb_c_get_print_frmt, psb_lc_get_print_frmt
!>
!! \memberof psb_lc_coo_sparse_mat
!! \see psb_lc_base_mat_mod::psb_lc_base_scalplusidentity
@@ -3729,6 +3837,56 @@ module psb_c_base_mat_mod
contains
function psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_ipk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='complex'
integer(psb_lpk_) :: nmx
integer(psb_ipk_) :: ni
nmx = max(nr,nc,ione)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_c_get_print_frmt
function psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_lpk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='complex'
integer(psb_lpk_) :: nmx
integer(psb_lpk_) :: ni
nmx = max(nr,nc,lone)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_lc_get_print_frmt
! == ==================================
!
base/modules/serial/psb_c_csc_mat_mod.f90
+2 -2
View File
@@ -219,9 +219,9 @@ module psb_c_csc_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_c_csc_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_c_csc_print
end interface
base/modules/serial/psb_c_csr_mat_mod.f90
+2 -2
View File
@@ -169,9 +169,9 @@ module psb_c_csr_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_c_csr_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_c_csr_print
end interface
!
base/modules/serial/psb_c_mat_mod.F90
+30 -6
View File
@@ -145,8 +145,9 @@ module psb_c_mat_mod
procedure, pass(a) :: tril => psb_c_tril
procedure, pass(a) :: triu => psb_c_triu
procedure, pass(a) :: m_csclip => psb_c_csclip
procedure, pass(a) :: m_csclip_ip => psb_c_csclip_ip
procedure, pass(a) :: b_csclip => psb_c_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_c_clean_zeros
procedure, pass(a) :: reall => psb_c_reallocate_nz
procedure, pass(a) :: get_neigh => psb_c_get_neigh
@@ -342,8 +343,9 @@ module psb_c_mat_mod
procedure, pass(a) :: tril => psb_lc_tril
procedure, pass(a) :: triu => psb_lc_triu
procedure, pass(a) :: m_csclip => psb_lc_csclip
procedure, pass(a) :: m_csclip_ip => psb_lc_csclip_ip
procedure, pass(a) :: b_csclip => psb_lc_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_lc_clean_zeros
procedure, pass(a) :: reall => psb_lc_reallocate_nz
procedure, pass(a) :: get_neigh => psb_lc_get_neigh
@@ -573,9 +575,9 @@ module psb_c_mat_mod
import :: psb_ipk_, psb_lpk_, psb_cspmat_type
integer(psb_ipk_), intent(in) :: iout
class(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_c_sparse_print
end interface
@@ -584,9 +586,9 @@ module psb_c_mat_mod
import :: psb_ipk_, psb_lpk_, psb_cspmat_type
character(len=*), intent(in) :: fname
class(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_c_n_sparse_print
end interface
@@ -745,6 +747,17 @@ module psb_c_mat_mod
end subroutine psb_c_csclip
end interface
interface
subroutine psb_c_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_c_csclip_ip
end interface
interface
subroutine psb_c_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -1514,6 +1527,17 @@ module psb_c_mat_mod
end subroutine psb_lc_csclip
end interface
interface
subroutine psb_lc_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_
class(psb_lcspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_lc_csclip_ip
end interface
interface
subroutine psb_lc_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
base/modules/serial/psb_c_serial_mod.f90
+4 -4
View File
@@ -292,9 +292,9 @@ contains
use psb_c_mat_mod, only : psb_cspmat_type
integer(psb_ipk_), intent(in) :: iout
type(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(iout,iv,head,ivr,ivc)
@@ -304,9 +304,9 @@ contains
use psb_c_mat_mod, only : psb_cspmat_type
character(len=*), intent(in) :: fname
type(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(fname,iv,head,ivr,ivc)
base/modules/serial/psb_d_base_mat_mod.F90
+160 -2
View File
@@ -167,6 +167,7 @@ module psb_d_base_mat_mod
procedure, pass(a) :: sizeof => d_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_d_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_d_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_d_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_d_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_d_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_d_cp_coo_to_fmt
@@ -191,6 +192,7 @@ module psb_d_base_mat_mod
procedure, pass(a) :: fix => psb_d_fix_coo
procedure, pass(a) :: trim => psb_d_coo_trim
procedure, pass(a) :: clean_zeros => psb_d_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_d_coo_clean_negidx
procedure, pass(a) :: print => psb_d_coo_print
procedure, pass(a) :: free => d_coo_free
procedure, pass(a) :: mold => psb_d_coo_mold
@@ -360,6 +362,7 @@ module psb_d_base_mat_mod
procedure, pass(a) :: sizeof => ld_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_ld_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_ld_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_ld_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_ld_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_ld_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_ld_cp_coo_to_fmt
@@ -380,6 +383,7 @@ module psb_d_base_mat_mod
procedure, pass(a) :: fix => psb_ld_fix_coo
procedure, pass(a) :: trim => psb_ld_coo_trim
procedure, pass(a) :: clean_zeros => psb_ld_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_ld_coo_clean_negidx
procedure, pass(a) :: print => psb_ld_coo_print
procedure, pass(a) :: free => ld_coo_free
procedure, pass(a) :: mold => psb_ld_coo_mold
@@ -1678,6 +1682,17 @@ module psb_d_base_mat_mod
class(psb_d_coo_sparse_mat), intent(inout) :: a
end subroutine psb_d_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_d_coo_sparse_mat
!
interface
subroutine psb_d_coo_ensure_size(nz,a)
import
integer(psb_ipk_), intent(in) :: nz
class(psb_d_coo_sparse_mat), intent(inout) :: a
end subroutine psb_d_coo_ensure_size
end interface
!
!>
@@ -1715,6 +1730,46 @@ module psb_d_base_mat_mod
end subroutine psb_d_coo_clean_zeros
end interface
!
!>
!! \memberof psb_d_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_d_coo_clean_negidx(a,info)
import
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_coo_clean_negidx
end interface
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
real(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
!
!>
!! \memberof psb_d_coo_sparse_mat
@@ -1759,9 +1814,9 @@ module psb_d_base_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_d_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_coo_print
end interface
@@ -3279,6 +3334,17 @@ module psb_d_base_mat_mod
class(psb_ld_coo_sparse_mat), intent(inout) :: a
end subroutine psb_ld_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_ld_coo_sparse_mat
!
interface
subroutine psb_ld_coo_ensure_size(nz,a)
import
integer(psb_lpk_), intent(in) :: nz
class(psb_ld_coo_sparse_mat), intent(inout) :: a
end subroutine psb_ld_coo_ensure_size
end interface
!
!>
@@ -3316,6 +3382,46 @@ module psb_d_base_mat_mod
end subroutine psb_ld_coo_clean_zeros
end interface
!
!>
!! \memberof psb_ld_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_ld_coo_clean_negidx(a,info)
import
class(psb_ld_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ld_coo_clean_negidx
end interface
#if defined(IPK4) && defined(LPK8)
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
real(psb_dpk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ld_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
#endif
!
!>
!! \memberof psb_ld_coo_sparse_mat
@@ -3674,6 +3780,8 @@ module psb_d_base_mat_mod
end subroutine psb_ld_coo_scals
end interface
public :: psb_d_get_print_frmt, psb_ld_get_print_frmt
!>
!! \memberof psb_ld_coo_sparse_mat
!! \see psb_ld_base_mat_mod::psb_ld_base_scalplusidentity
@@ -3729,6 +3837,56 @@ module psb_d_base_mat_mod
contains
function psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_ipk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='real'
integer(psb_lpk_) :: nmx
integer(psb_ipk_) :: ni
nmx = max(nr,nc,ione)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_d_get_print_frmt
function psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_lpk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='real'
integer(psb_lpk_) :: nmx
integer(psb_lpk_) :: ni
nmx = max(nr,nc,lone)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_ld_get_print_frmt
! == ==================================
!
base/modules/serial/psb_d_csc_mat_mod.f90
+2 -2
View File
@@ -219,9 +219,9 @@ module psb_d_csc_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_d_csc_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_csc_print
end interface
base/modules/serial/psb_d_csr_mat_mod.f90
+2 -2
View File
@@ -169,9 +169,9 @@ module psb_d_csr_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_d_csr_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_csr_print
end interface
!
base/modules/serial/psb_d_mat_mod.F90
+30 -6
View File
@@ -145,8 +145,9 @@ module psb_d_mat_mod
procedure, pass(a) :: tril => psb_d_tril
procedure, pass(a) :: triu => psb_d_triu
procedure, pass(a) :: m_csclip => psb_d_csclip
procedure, pass(a) :: m_csclip_ip => psb_d_csclip_ip
procedure, pass(a) :: b_csclip => psb_d_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_d_clean_zeros
procedure, pass(a) :: reall => psb_d_reallocate_nz
procedure, pass(a) :: get_neigh => psb_d_get_neigh
@@ -342,8 +343,9 @@ module psb_d_mat_mod
procedure, pass(a) :: tril => psb_ld_tril
procedure, pass(a) :: triu => psb_ld_triu
procedure, pass(a) :: m_csclip => psb_ld_csclip
procedure, pass(a) :: m_csclip_ip => psb_ld_csclip_ip
procedure, pass(a) :: b_csclip => psb_ld_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_ld_clean_zeros
procedure, pass(a) :: reall => psb_ld_reallocate_nz
procedure, pass(a) :: get_neigh => psb_ld_get_neigh
@@ -573,9 +575,9 @@ module psb_d_mat_mod
import :: psb_ipk_, psb_lpk_, psb_dspmat_type
integer(psb_ipk_), intent(in) :: iout
class(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_sparse_print
end interface
@@ -584,9 +586,9 @@ module psb_d_mat_mod
import :: psb_ipk_, psb_lpk_, psb_dspmat_type
character(len=*), intent(in) :: fname
class(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_n_sparse_print
end interface
@@ -745,6 +747,17 @@ module psb_d_mat_mod
end subroutine psb_d_csclip
end interface
interface
subroutine psb_d_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_d_csclip_ip
end interface
interface
subroutine psb_d_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -1514,6 +1527,17 @@ module psb_d_mat_mod
end subroutine psb_ld_csclip
end interface
interface
subroutine psb_ld_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_
class(psb_ldspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_ld_csclip_ip
end interface
interface
subroutine psb_ld_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
base/modules/serial/psb_d_serial_mod.f90
+4 -4
View File
@@ -292,9 +292,9 @@ contains
use psb_d_mat_mod, only : psb_dspmat_type
integer(psb_ipk_), intent(in) :: iout
type(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(iout,iv,head,ivr,ivc)
@@ -304,9 +304,9 @@ contains
use psb_d_mat_mod, only : psb_dspmat_type
character(len=*), intent(in) :: fname
type(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(fname,iv,head,ivr,ivc)
base/modules/serial/psb_s_base_mat_mod.F90
+160 -2
View File
@@ -167,6 +167,7 @@ module psb_s_base_mat_mod
procedure, pass(a) :: sizeof => s_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_s_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_s_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_s_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_s_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_s_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_s_cp_coo_to_fmt
@@ -191,6 +192,7 @@ module psb_s_base_mat_mod
procedure, pass(a) :: fix => psb_s_fix_coo
procedure, pass(a) :: trim => psb_s_coo_trim
procedure, pass(a) :: clean_zeros => psb_s_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_s_coo_clean_negidx
procedure, pass(a) :: print => psb_s_coo_print
procedure, pass(a) :: free => s_coo_free
procedure, pass(a) :: mold => psb_s_coo_mold
@@ -360,6 +362,7 @@ module psb_s_base_mat_mod
procedure, pass(a) :: sizeof => ls_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_ls_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_ls_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_ls_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_ls_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_ls_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_ls_cp_coo_to_fmt
@@ -380,6 +383,7 @@ module psb_s_base_mat_mod
procedure, pass(a) :: fix => psb_ls_fix_coo
procedure, pass(a) :: trim => psb_ls_coo_trim
procedure, pass(a) :: clean_zeros => psb_ls_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_ls_coo_clean_negidx
procedure, pass(a) :: print => psb_ls_coo_print
procedure, pass(a) :: free => ls_coo_free
procedure, pass(a) :: mold => psb_ls_coo_mold
@@ -1678,6 +1682,17 @@ module psb_s_base_mat_mod
class(psb_s_coo_sparse_mat), intent(inout) :: a
end subroutine psb_s_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_s_coo_sparse_mat
!
interface
subroutine psb_s_coo_ensure_size(nz,a)
import
integer(psb_ipk_), intent(in) :: nz
class(psb_s_coo_sparse_mat), intent(inout) :: a
end subroutine psb_s_coo_ensure_size
end interface
!
!>
@@ -1715,6 +1730,46 @@ module psb_s_base_mat_mod
end subroutine psb_s_coo_clean_zeros
end interface
!
!>
!! \memberof psb_s_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_s_coo_clean_negidx(a,info)
import
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_coo_clean_negidx
end interface
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
real(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
!
!>
!! \memberof psb_s_coo_sparse_mat
@@ -1759,9 +1814,9 @@ module psb_s_base_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_s_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_s_coo_print
end interface
@@ -3279,6 +3334,17 @@ module psb_s_base_mat_mod
class(psb_ls_coo_sparse_mat), intent(inout) :: a
end subroutine psb_ls_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_ls_coo_sparse_mat
!
interface
subroutine psb_ls_coo_ensure_size(nz,a)
import
integer(psb_lpk_), intent(in) :: nz
class(psb_ls_coo_sparse_mat), intent(inout) :: a
end subroutine psb_ls_coo_ensure_size
end interface
!
!>
@@ -3316,6 +3382,46 @@ module psb_s_base_mat_mod
end subroutine psb_ls_coo_clean_zeros
end interface
!
!>
!! \memberof psb_ls_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_ls_coo_clean_negidx(a,info)
import
class(psb_ls_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ls_coo_clean_negidx
end interface
#if defined(IPK4) && defined(LPK8)
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
real(psb_spk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ls_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
#endif
!
!>
!! \memberof psb_ls_coo_sparse_mat
@@ -3674,6 +3780,8 @@ module psb_s_base_mat_mod
end subroutine psb_ls_coo_scals
end interface
public :: psb_s_get_print_frmt, psb_ls_get_print_frmt
!>
!! \memberof psb_ls_coo_sparse_mat
!! \see psb_ls_base_mat_mod::psb_ls_base_scalplusidentity
@@ -3729,6 +3837,56 @@ module psb_s_base_mat_mod
contains
function psb_s_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_ipk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='real'
integer(psb_lpk_) :: nmx
integer(psb_ipk_) :: ni
nmx = max(nr,nc,ione)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_s_get_print_frmt
function psb_ls_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_lpk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='real'
integer(psb_lpk_) :: nmx
integer(psb_lpk_) :: ni
nmx = max(nr,nc,lone)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_ls_get_print_frmt
! == ==================================
!
base/modules/serial/psb_s_csc_mat_mod.f90
+2 -2
View File
@@ -219,9 +219,9 @@ module psb_s_csc_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_s_csc_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_s_csc_print
end interface
base/modules/serial/psb_s_csr_mat_mod.f90
+2 -2
View File
@@ -169,9 +169,9 @@ module psb_s_csr_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_s_csr_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_s_csr_print
end interface
!
base/modules/serial/psb_s_mat_mod.F90
+30 -6
View File
@@ -145,8 +145,9 @@ module psb_s_mat_mod
procedure, pass(a) :: tril => psb_s_tril
procedure, pass(a) :: triu => psb_s_triu
procedure, pass(a) :: m_csclip => psb_s_csclip
procedure, pass(a) :: m_csclip_ip => psb_s_csclip_ip
procedure, pass(a) :: b_csclip => psb_s_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_s_clean_zeros
procedure, pass(a) :: reall => psb_s_reallocate_nz
procedure, pass(a) :: get_neigh => psb_s_get_neigh
@@ -342,8 +343,9 @@ module psb_s_mat_mod
procedure, pass(a) :: tril => psb_ls_tril
procedure, pass(a) :: triu => psb_ls_triu
procedure, pass(a) :: m_csclip => psb_ls_csclip
procedure, pass(a) :: m_csclip_ip => psb_ls_csclip_ip
procedure, pass(a) :: b_csclip => psb_ls_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_ls_clean_zeros
procedure, pass(a) :: reall => psb_ls_reallocate_nz
procedure, pass(a) :: get_neigh => psb_ls_get_neigh
@@ -573,9 +575,9 @@ module psb_s_mat_mod
import :: psb_ipk_, psb_lpk_, psb_sspmat_type
integer(psb_ipk_), intent(in) :: iout
class(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_s_sparse_print
end interface
@@ -584,9 +586,9 @@ module psb_s_mat_mod
import :: psb_ipk_, psb_lpk_, psb_sspmat_type
character(len=*), intent(in) :: fname
class(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_s_n_sparse_print
end interface
@@ -745,6 +747,17 @@ module psb_s_mat_mod
end subroutine psb_s_csclip
end interface
interface
subroutine psb_s_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_s_csclip_ip
end interface
interface
subroutine psb_s_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -1514,6 +1527,17 @@ module psb_s_mat_mod
end subroutine psb_ls_csclip
end interface
interface
subroutine psb_ls_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_
class(psb_lsspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_ls_csclip_ip
end interface
interface
subroutine psb_ls_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
base/modules/serial/psb_s_serial_mod.f90
+4 -4
View File
@@ -292,9 +292,9 @@ contains
use psb_s_mat_mod, only : psb_sspmat_type
integer(psb_ipk_), intent(in) :: iout
type(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(iout,iv,head,ivr,ivc)
@@ -304,9 +304,9 @@ contains
use psb_s_mat_mod, only : psb_sspmat_type
character(len=*), intent(in) :: fname
type(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(fname,iv,head,ivr,ivc)
base/modules/serial/psb_z_base_mat_mod.F90
+160 -2
View File
@@ -167,6 +167,7 @@ module psb_z_base_mat_mod
procedure, pass(a) :: sizeof => z_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_z_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_z_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_z_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_z_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_z_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_z_cp_coo_to_fmt
@@ -191,6 +192,7 @@ module psb_z_base_mat_mod
procedure, pass(a) :: fix => psb_z_fix_coo
procedure, pass(a) :: trim => psb_z_coo_trim
procedure, pass(a) :: clean_zeros => psb_z_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_z_coo_clean_negidx
procedure, pass(a) :: print => psb_z_coo_print
procedure, pass(a) :: free => z_coo_free
procedure, pass(a) :: mold => psb_z_coo_mold
@@ -360,6 +362,7 @@ module psb_z_base_mat_mod
procedure, pass(a) :: sizeof => lz_coo_sizeof
procedure, pass(a) :: reallocate_nz => psb_lz_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_lz_coo_allocate_mnnz
procedure, pass(a) :: ensure_size => psb_lz_coo_ensure_size
procedure, pass(a) :: cp_to_coo => psb_lz_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => psb_lz_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => psb_lz_cp_coo_to_fmt
@@ -380,6 +383,7 @@ module psb_z_base_mat_mod
procedure, pass(a) :: fix => psb_lz_fix_coo
procedure, pass(a) :: trim => psb_lz_coo_trim
procedure, pass(a) :: clean_zeros => psb_lz_coo_clean_zeros
procedure, pass(a) :: clean_negidx => psb_lz_coo_clean_negidx
procedure, pass(a) :: print => psb_lz_coo_print
procedure, pass(a) :: free => lz_coo_free
procedure, pass(a) :: mold => psb_lz_coo_mold
@@ -1678,6 +1682,17 @@ module psb_z_base_mat_mod
class(psb_z_coo_sparse_mat), intent(inout) :: a
end subroutine psb_z_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_z_coo_sparse_mat
!
interface
subroutine psb_z_coo_ensure_size(nz,a)
import
integer(psb_ipk_), intent(in) :: nz
class(psb_z_coo_sparse_mat), intent(inout) :: a
end subroutine psb_z_coo_ensure_size
end interface
!
!>
@@ -1715,6 +1730,46 @@ module psb_z_base_mat_mod
end subroutine psb_z_coo_clean_zeros
end interface
!
!>
!! \memberof psb_z_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_z_coo_clean_negidx(a,info)
import
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_coo_clean_negidx
end interface
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_z_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
complex(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
!
!>
!! \memberof psb_z_coo_sparse_mat
@@ -1759,9 +1814,9 @@ module psb_z_base_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_z_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_z_coo_print
end interface
@@ -3279,6 +3334,17 @@ module psb_z_base_mat_mod
class(psb_lz_coo_sparse_mat), intent(inout) :: a
end subroutine psb_lz_coo_reallocate_nz
end interface
!
!>
!! \memberof psb_lz_coo_sparse_mat
!
interface
subroutine psb_lz_coo_ensure_size(nz,a)
import
integer(psb_lpk_), intent(in) :: nz
class(psb_lz_coo_sparse_mat), intent(inout) :: a
end subroutine psb_lz_coo_ensure_size
end interface
!
!>
@@ -3316,6 +3382,46 @@ module psb_z_base_mat_mod
end subroutine psb_lz_coo_clean_zeros
end interface
!
!>
!! \memberof psb_lz_coo_sparse_mat
!! \brief Take out any entries with negative row or column index
!! May happen when converting local/global numbering
!! \param info return code
!!
!
interface
subroutine psb_lz_coo_clean_negidx(a,info)
import
class(psb_lz_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lz_coo_clean_negidx
end interface
#if defined(IPK4) && defined(LPK8)
!
!> Funtion: coo_clean_negidx_inner
!! \brief Take out any entries with negative row or column index
!! Used internally by coo_clean_negidx
!! \param nzin Number of entries on input to be handled
!! \param ia(:) Row indices
!! \param ja(:) Col indices
!! \param val(:) Coefficients
!! \param nzout Number of entries after sorting/duplicate handling
!! \param info return code
!!
!
interface psb_coo_clean_negidx_inner
subroutine psb_lz_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
import
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
complex(psb_dpk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lz_coo_clean_negidx_inner
end interface psb_coo_clean_negidx_inner
#endif
!
!>
!! \memberof psb_lz_coo_sparse_mat
@@ -3674,6 +3780,8 @@ module psb_z_base_mat_mod
end subroutine psb_lz_coo_scals
end interface
public :: psb_z_get_print_frmt, psb_lz_get_print_frmt
!>
!! \memberof psb_lz_coo_sparse_mat
!! \see psb_lz_base_mat_mod::psb_lz_base_scalplusidentity
@@ -3729,6 +3837,56 @@ module psb_z_base_mat_mod
contains
function psb_z_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_ipk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='complex'
integer(psb_lpk_) :: nmx
integer(psb_ipk_) :: ni
nmx = max(nr,nc,ione)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_z_get_print_frmt
function psb_lz_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt)
implicit none
character(len=80) :: frmt
integer(psb_lpk_), intent(in) :: nr, nc, nz
integer(psb_lpk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
!
character(len=*), parameter :: datatype='complex'
integer(psb_lpk_) :: nmx
integer(psb_lpk_) :: ni
nmx = max(nr,nc,lone)
if (present(iv)) nmx = max(nmx,maxval(abs(iv(1:nc))))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr))))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc))))
ni = floor(log10(1.0*nmx)) + 2
if (datatype=='complex') then
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
else
write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
end if
end function psb_lz_get_print_frmt
! == ==================================
!
base/modules/serial/psb_z_csc_mat_mod.f90
+2 -2
View File
@@ -219,9 +219,9 @@ module psb_z_csc_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_z_csc_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_z_csc_print
end interface
base/modules/serial/psb_z_csr_mat_mod.f90
+2 -2
View File
@@ -169,9 +169,9 @@ module psb_z_csr_mat_mod
import
integer(psb_ipk_), intent(in) :: iout
class(psb_z_csr_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_z_csr_print
end interface
!
base/modules/serial/psb_z_mat_mod.F90
+30 -6
View File
@@ -145,8 +145,9 @@ module psb_z_mat_mod
procedure, pass(a) :: tril => psb_z_tril
procedure, pass(a) :: triu => psb_z_triu
procedure, pass(a) :: m_csclip => psb_z_csclip
procedure, pass(a) :: m_csclip_ip => psb_z_csclip_ip
procedure, pass(a) :: b_csclip => psb_z_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_z_clean_zeros
procedure, pass(a) :: reall => psb_z_reallocate_nz
procedure, pass(a) :: get_neigh => psb_z_get_neigh
@@ -342,8 +343,9 @@ module psb_z_mat_mod
procedure, pass(a) :: tril => psb_lz_tril
procedure, pass(a) :: triu => psb_lz_triu
procedure, pass(a) :: m_csclip => psb_lz_csclip
procedure, pass(a) :: m_csclip_ip => psb_lz_csclip_ip
procedure, pass(a) :: b_csclip => psb_lz_b_csclip
generic, public :: csclip => b_csclip, m_csclip
generic, public :: csclip => b_csclip, m_csclip, m_csclip_ip
procedure, pass(a) :: clean_zeros => psb_lz_clean_zeros
procedure, pass(a) :: reall => psb_lz_reallocate_nz
procedure, pass(a) :: get_neigh => psb_lz_get_neigh
@@ -573,9 +575,9 @@ module psb_z_mat_mod
import :: psb_ipk_, psb_lpk_, psb_zspmat_type
integer(psb_ipk_), intent(in) :: iout
class(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_z_sparse_print
end interface
@@ -584,9 +586,9 @@ module psb_z_mat_mod
import :: psb_ipk_, psb_lpk_, psb_zspmat_type
character(len=*), intent(in) :: fname
class(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_z_n_sparse_print
end interface
@@ -745,6 +747,17 @@ module psb_z_mat_mod
end subroutine psb_z_csclip
end interface
interface
subroutine psb_z_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_z_csclip_ip
end interface
interface
subroutine psb_z_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -1514,6 +1527,17 @@ module psb_z_mat_mod
end subroutine psb_lz_csclip
end interface
interface
subroutine psb_lz_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_
class(psb_lzspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_lz_csclip_ip
end interface
interface
subroutine psb_lz_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
base/modules/serial/psb_z_serial_mod.f90
+4 -4
View File
@@ -292,9 +292,9 @@ contains
use psb_z_mat_mod, only : psb_zspmat_type
integer(psb_ipk_), intent(in) :: iout
type(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(iout,iv,head,ivr,ivc)
@@ -304,9 +304,9 @@ contains
use psb_z_mat_mod, only : psb_zspmat_type
character(len=*), intent(in) :: fname
type(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:),ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:),ivc(:)
call a%print(fname,iv,head,ivr,ivc)
base/modules/tools/psb_c_tools_mod.f90 → base/modules/tools/psb_c_tools_mod.F90
+77 -1
View File
@@ -32,7 +32,9 @@
Module psb_c_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_
use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type
use psb_c_mat_mod, only : psb_cspmat_type, psb_lcspmat_type, psb_c_base_sparse_mat, psb_lc_csr_sparse_mat
use psb_c_mat_mod, only : psb_cspmat_type, psb_lcspmat_type, psb_c_base_sparse_mat, &
& psb_lc_csr_sparse_mat, psb_lc_coo_sparse_mat, &
& psb_c_csr_sparse_mat, psb_c_coo_sparse_mat
use psb_l_vect_mod, only : psb_l_vect_type
use psb_c_multivect_mod, only : psb_c_base_multivect_type, psb_c_multivect_type
@@ -220,6 +222,18 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_lc_csr_halo
Subroutine psb_c_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,data,outcol_glob,col_desc)
import
implicit none
type(psb_c_csr_sparse_mat),Intent(in) :: a
type(psb_lc_csr_sparse_mat),Intent(inout) :: blk
type(psb_desc_type),intent(in), target :: desc_a
integer(psb_ipk_), intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_c_lc_csr_halo
end interface
@@ -282,6 +296,7 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_cspins_csr_lirp
#if defined(IPK4) && defined(LPK8)
subroutine psb_cspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local)
import
implicit none
@@ -293,6 +308,7 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_cspins_csr_iirp
#endif
subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import
@@ -332,6 +348,17 @@ Module psb_c_tools_mod
end interface
interface psb_par_spspmm
subroutine psb_c_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_c_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
type(psb_c_csr_sparse_mat),intent(in) :: acsr
type(psb_c_csr_sparse_mat),intent(inout) :: bcsr
type(psb_c_csr_sparse_mat),intent(out) :: ccsr
type(psb_desc_type),intent(in) :: desc_a
type(psb_desc_type),intent(inout) :: desc_c
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_c_par_csr_spspmm
subroutine psb_lc_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_lc_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
@@ -344,5 +371,54 @@ Module psb_c_tools_mod
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_lc_par_csr_spspmm
end interface psb_par_spspmm
interface psb_glob_transpose
subroutine psb_c_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_c_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_c_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_coo_glob_transpose
subroutine psb_lc_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_lc_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_lc_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lc_coo_glob_transpose
subroutine psb_lc_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_lcspmat_type), intent(in) :: ain
type(psb_lcspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lc_simple_glob_transpose
subroutine psb_lc_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_lcspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lc_simple_glob_transpose_ip
subroutine psb_c_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_cspmat_type), intent(in) :: ain
type(psb_cspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_simple_glob_transpose
subroutine psb_c_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_cspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_simple_glob_transpose_ip
end interface psb_glob_transpose
end module psb_c_tools_mod
base/modules/tools/psb_cd_tools_mod.f90 → base/modules/tools/psb_cd_tools_mod.F90
+2
View File
@@ -104,6 +104,7 @@ module psb_cd_tools_mod
end interface
interface psb_cdins
#if defined(IPK4) && defined(LPK8)
subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla)
import :: psb_ipk_, psb_lpk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc_a
@@ -122,6 +123,7 @@ module psb_cd_tools_mod
logical, optional, target, intent(in) :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
end subroutine psb_cdinsc
#endif
subroutine psb_lcdinsrc(nz,ia,ja,desc_a,info,ila,jla)
import :: psb_ipk_, psb_lpk_, psb_desc_type
type(psb_desc_type), intent(inout) :: desc_a
base/modules/tools/psb_d_tools_mod.f90 → base/modules/tools/psb_d_tools_mod.F90
+77 -1
View File
@@ -32,7 +32,9 @@
Module psb_d_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_
use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type
use psb_d_mat_mod, only : psb_dspmat_type, psb_ldspmat_type, psb_d_base_sparse_mat, psb_ld_csr_sparse_mat
use psb_d_mat_mod, only : psb_dspmat_type, psb_ldspmat_type, psb_d_base_sparse_mat, &
& psb_ld_csr_sparse_mat, psb_ld_coo_sparse_mat, &
& psb_d_csr_sparse_mat, psb_d_coo_sparse_mat
use psb_l_vect_mod, only : psb_l_vect_type
use psb_d_multivect_mod, only : psb_d_base_multivect_type, psb_d_multivect_type
@@ -220,6 +222,18 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_ld_csr_halo
Subroutine psb_d_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,data,outcol_glob,col_desc)
import
implicit none
type(psb_d_csr_sparse_mat),Intent(in) :: a
type(psb_ld_csr_sparse_mat),Intent(inout) :: blk
type(psb_desc_type),intent(in), target :: desc_a
integer(psb_ipk_), intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_d_ld_csr_halo
end interface
@@ -282,6 +296,7 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_dspins_csr_lirp
#if defined(IPK4) && defined(LPK8)
subroutine psb_dspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local)
import
implicit none
@@ -293,6 +308,7 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_dspins_csr_iirp
#endif
subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import
@@ -332,6 +348,17 @@ Module psb_d_tools_mod
end interface
interface psb_par_spspmm
subroutine psb_d_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_d_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
type(psb_d_csr_sparse_mat),intent(in) :: acsr
type(psb_d_csr_sparse_mat),intent(inout) :: bcsr
type(psb_d_csr_sparse_mat),intent(out) :: ccsr
type(psb_desc_type),intent(in) :: desc_a
type(psb_desc_type),intent(inout) :: desc_c
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_d_par_csr_spspmm
subroutine psb_ld_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_ld_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
@@ -344,5 +371,54 @@ Module psb_d_tools_mod
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_ld_par_csr_spspmm
end interface psb_par_spspmm
interface psb_glob_transpose
subroutine psb_d_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_d_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_d_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_coo_glob_transpose
subroutine psb_ld_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_ld_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_ld_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ld_coo_glob_transpose
subroutine psb_ld_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_ldspmat_type), intent(in) :: ain
type(psb_ldspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ld_simple_glob_transpose
subroutine psb_ld_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_ldspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ld_simple_glob_transpose_ip
subroutine psb_d_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_dspmat_type), intent(in) :: ain
type(psb_dspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_simple_glob_transpose
subroutine psb_d_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_dspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_simple_glob_transpose_ip
end interface psb_glob_transpose
end module psb_d_tools_mod
base/modules/tools/psb_i2_tools_a_mod.f90
+119
View File
@@ -0,0 +1,119 @@
!
! 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.
!
!
Module psb_i2_tools_a_mod
use psb_desc_mod, only : psb_desc_type, psb_i2pk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_
interface psb_geall
subroutine psb_i2alloc(x, desc_a, info, n, lb)
import
implicit none
integer(psb_i2pk_), 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
end subroutine psb_i2alloc
subroutine psb_i2allocv(x, desc_a,info,n)
import
implicit none
integer(psb_i2pk_), 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
end subroutine psb_i2allocv
end interface
interface psb_geasb
subroutine psb_i2asb(x, desc_a, info, scratch)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer(psb_i2pk_), allocatable, intent(inout) :: x(:,:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
end subroutine psb_i2asb
subroutine psb_i2asbv(x, desc_a, info, scratch)
import
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer(psb_i2pk_), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
end subroutine psb_i2asbv
end interface
interface psb_gefree
subroutine psb_i2free(x, desc_a, info)
import
implicit none
integer(psb_i2pk_),allocatable, intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i2free
subroutine psb_i2freev(x, desc_a, info)
import
implicit none
integer(psb_i2pk_),allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_i2freev
end interface
interface psb_geins
subroutine psb_i2insi(m,irw,val, x, desc_a,info,dupl,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
integer(psb_i2pk_),intent(inout) :: x(:,:)
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_i2pk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_i2insi
subroutine psb_i2insvi(m, irw,val, x,desc_a,info,dupl,local)
import
implicit none
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
integer(psb_i2pk_),intent(inout) :: x(:)
integer(psb_lpk_), intent(in) :: irw(:)
integer(psb_i2pk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_i2insvi
end interface
end module psb_i2_tools_a_mod
base/modules/tools/psb_i_tools_mod.f90 → base/modules/tools/psb_i_tools_mod.F90
View File
base/modules/tools/psb_l_tools_mod.f90 → base/modules/tools/psb_l_tools_mod.F90
View File
base/modules/tools/psb_s_tools_mod.f90 → base/modules/tools/psb_s_tools_mod.F90
+77 -1
View File
@@ -32,7 +32,9 @@
Module psb_s_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_
use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type
use psb_s_mat_mod, only : psb_sspmat_type, psb_lsspmat_type, psb_s_base_sparse_mat, psb_ls_csr_sparse_mat
use psb_s_mat_mod, only : psb_sspmat_type, psb_lsspmat_type, psb_s_base_sparse_mat, &
& psb_ls_csr_sparse_mat, psb_ls_coo_sparse_mat, &
& psb_s_csr_sparse_mat, psb_s_coo_sparse_mat
use psb_l_vect_mod, only : psb_l_vect_type
use psb_s_multivect_mod, only : psb_s_base_multivect_type, psb_s_multivect_type
@@ -220,6 +222,18 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_ls_csr_halo
Subroutine psb_s_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,data,outcol_glob,col_desc)
import
implicit none
type(psb_s_csr_sparse_mat),Intent(in) :: a
type(psb_ls_csr_sparse_mat),Intent(inout) :: blk
type(psb_desc_type),intent(in), target :: desc_a
integer(psb_ipk_), intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_s_ls_csr_halo
end interface
@@ -282,6 +296,7 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_sspins_csr_lirp
#if defined(IPK4) && defined(LPK8)
subroutine psb_sspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local)
import
implicit none
@@ -293,6 +308,7 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_sspins_csr_iirp
#endif
subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import
@@ -332,6 +348,17 @@ Module psb_s_tools_mod
end interface
interface psb_par_spspmm
subroutine psb_s_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_s_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
type(psb_s_csr_sparse_mat),intent(in) :: acsr
type(psb_s_csr_sparse_mat),intent(inout) :: bcsr
type(psb_s_csr_sparse_mat),intent(out) :: ccsr
type(psb_desc_type),intent(in) :: desc_a
type(psb_desc_type),intent(inout) :: desc_c
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_s_par_csr_spspmm
subroutine psb_ls_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_ls_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
@@ -344,5 +371,54 @@ Module psb_s_tools_mod
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_ls_par_csr_spspmm
end interface psb_par_spspmm
interface psb_glob_transpose
subroutine psb_s_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_s_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_s_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_coo_glob_transpose
subroutine psb_ls_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_ls_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_ls_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ls_coo_glob_transpose
subroutine psb_ls_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_lsspmat_type), intent(in) :: ain
type(psb_lsspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ls_simple_glob_transpose
subroutine psb_ls_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_lsspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_ls_simple_glob_transpose_ip
subroutine psb_s_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_sspmat_type), intent(in) :: ain
type(psb_sspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_simple_glob_transpose
subroutine psb_s_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_sspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_simple_glob_transpose_ip
end interface psb_glob_transpose
end module psb_s_tools_mod
base/modules/tools/psb_z_tools_mod.f90 → base/modules/tools/psb_z_tools_mod.F90
+77 -1
View File
@@ -32,7 +32,9 @@
Module psb_z_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_
use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type
use psb_z_mat_mod, only : psb_zspmat_type, psb_lzspmat_type, psb_z_base_sparse_mat, psb_lz_csr_sparse_mat
use psb_z_mat_mod, only : psb_zspmat_type, psb_lzspmat_type, psb_z_base_sparse_mat, &
& psb_lz_csr_sparse_mat, psb_lz_coo_sparse_mat, &
& psb_z_csr_sparse_mat, psb_z_coo_sparse_mat
use psb_l_vect_mod, only : psb_l_vect_type
use psb_z_multivect_mod, only : psb_z_base_multivect_type, psb_z_multivect_type
@@ -220,6 +222,18 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_lz_csr_halo
Subroutine psb_z_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,data,outcol_glob,col_desc)
import
implicit none
type(psb_z_csr_sparse_mat),Intent(in) :: a
type(psb_lz_csr_sparse_mat),Intent(inout) :: blk
type(psb_desc_type),intent(in), target :: desc_a
integer(psb_ipk_), intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob
integer(psb_ipk_), intent(in), optional :: data
type(psb_desc_type),Intent(in), optional, target :: col_desc
end Subroutine psb_z_lz_csr_halo
end interface
@@ -282,6 +296,7 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_zspins_csr_lirp
#if defined(IPK4) && defined(LPK8)
subroutine psb_zspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local)
import
implicit none
@@ -293,6 +308,7 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
end subroutine psb_zspins_csr_iirp
#endif
subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import
@@ -332,6 +348,17 @@ Module psb_z_tools_mod
end interface
interface psb_par_spspmm
subroutine psb_z_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_z_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
type(psb_z_csr_sparse_mat),intent(in) :: acsr
type(psb_z_csr_sparse_mat),intent(inout) :: bcsr
type(psb_z_csr_sparse_mat),intent(out) :: ccsr
type(psb_desc_type),intent(in) :: desc_a
type(psb_desc_type),intent(inout) :: desc_c
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_z_par_csr_spspmm
subroutine psb_lz_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
import :: psb_lz_csr_sparse_mat, psb_desc_type, psb_ipk_
Implicit None
@@ -344,5 +371,54 @@ Module psb_z_tools_mod
integer(psb_ipk_), intent(in), optional :: data
End Subroutine psb_lz_par_csr_spspmm
end interface psb_par_spspmm
interface psb_glob_transpose
subroutine psb_z_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_z_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_z_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_coo_glob_transpose
subroutine psb_lz_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx)
import
type(psb_lz_coo_sparse_mat), intent(inout) :: ain
type(psb_desc_type), intent(inout), target :: desc_r
type(psb_lz_coo_sparse_mat), intent(out), optional :: atrans
type(psb_desc_type), intent(inout), target, optional :: desc_c
type(psb_desc_type), intent(out), optional :: desc_rx
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lz_coo_glob_transpose
subroutine psb_lz_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_lzspmat_type), intent(in) :: ain
type(psb_lzspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lz_simple_glob_transpose
subroutine psb_lz_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_lzspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_lz_simple_glob_transpose_ip
subroutine psb_z_simple_glob_transpose(ain,aout,desc_a,info)
import
type(psb_zspmat_type), intent(in) :: ain
type(psb_zspmat_type), intent(out) :: aout
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_simple_glob_transpose
subroutine psb_z_simple_glob_transpose_ip(ain,desc_a,info)
import
type(psb_zspmat_type), intent(inout) :: ain
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_simple_glob_transpose_ip
end interface psb_glob_transpose
end module psb_z_tools_mod
base/serial/Makefile
+4 -4
View File
@@ -29,12 +29,12 @@ lib: impld sortd lib1 $(FOBJS)
lib1: $(FOBJS)
impld:
cd impl && $(MAKE) lib
$(MAKE) -C impl lib
sortd:
cd sort && $(MAKE) lib
$(MAKE) -C sort lib
clean:
/bin/rm -f $(FOBJS) *$(.mod)
(cd impl; $(MAKE) clean)
(cd sort; $(MAKE) clean)
($(MAKE) -C impl clean)
($(MAKE) -C sort clean)
veryclean: clean
base/serial/impl/psb_c_coo_impl.f90 → base/serial/impl/psb_c_coo_impl.F90
+159 -40
View File
@@ -407,6 +407,38 @@ subroutine psb_c_coo_reallocate_nz(nz,a)
end subroutine psb_c_coo_reallocate_nz
subroutine psb_c_coo_ensure_size(nz,a)
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_ensure_size
use psb_error_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: nz
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
character(len=20) :: name='c_coo_ensure_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
nz_ = max(nz,ione)
call psb_ensure_size(nz_,a%ia,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%val,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_coo_ensure_size
subroutine psb_c_coo_mold(a,b,info)
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mold
use psb_error_mod
@@ -540,7 +572,44 @@ subroutine psb_c_coo_clean_zeros(a, info)
call a%trim()
end subroutine psb_c_coo_clean_zeros
subroutine psb_c_coo_clean_negidx(a,info)
use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_clean_negidx
implicit none
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_ipk_) :: nz
call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info)
if (info == 0) call a%set_nzeros(nz)
end subroutine psb_c_coo_clean_negidx
subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_clean_negidx_inner
implicit none
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
complex(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_ipk_) :: i
info = 0
nzout = 0
do i=1, nzin
if ((ia(i)>0).and.(ja(i)>0)) then
nzout = nzout + 1
val(nzout) = val(i)
ia(nzout) = ia(i)
ja(nzout) = ja(i)
end if
end do
end subroutine psb_c_coo_clean_negidx_inner
subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_allocate_mnnz
@@ -610,17 +679,15 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_c_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
if (present(head)) write(iout,'(a,a)') '% ',head
@@ -632,38 +699,29 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
write(iout,frmt) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif
@@ -1777,7 +1835,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
else if (ctra) then !
if (alpha == cone) then
i = 1
@@ -4910,6 +4968,38 @@ subroutine psb_lc_coo_reallocate_nz(nz,a)
end subroutine psb_lc_coo_reallocate_nz
subroutine psb_lc_coo_ensure_size(nz,a)
use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_ensure_size
use psb_error_mod
use psb_realloc_mod
implicit none
integer(psb_lpk_), intent(in) :: nz
class(psb_lc_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
character(len=20) :: name='lc_coo_ensure_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
nz_ = max(nz,ione)
call psb_ensure_size(nz_,a%ia,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%val,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_lc_coo_ensure_size
subroutine psb_lc_coo_mold(a,b,info)
use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mold
use psb_error_mod
@@ -5044,7 +5134,46 @@ subroutine psb_lc_coo_clean_zeros(a, info)
call a%trim()
end subroutine psb_lc_coo_clean_zeros
subroutine psb_lc_coo_clean_negidx(a,info)
use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_negidx
implicit none
class(psb_lc_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_lpk_) :: nz
call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info)
if (info == 0) call a%set_nzeros(nz)
end subroutine psb_lc_coo_clean_negidx
#if defined(IPK4) && defined(LPK8)
subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_negidx_inner
implicit none
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
complex(psb_spk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_lpk_) :: i
info = 0
nzout = 0
do i=1, nzin
if ((ia(i)>0).and.(ja(i)>0)) then
nzout = nzout + 1
val(nzout) = val(i)
ia(nzout) = ia(i)
ja(nzout) = ja(i)
end if
end do
end subroutine psb_lc_coo_clean_negidx_inner
#endif
subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz)
use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_allocate_mnnz
@@ -5123,9 +5252,8 @@ subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc)
character(len=20) :: name='lc_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
if (present(head)) write(iout,'(a,a)') '% ',head
@@ -5137,38 +5265,29 @@ subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
write(iout,frmt) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif
base/serial/impl/psb_c_csc_impl.f90
+18 -38
View File
@@ -2706,9 +2706,9 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_c_csc_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
@@ -2716,7 +2716,7 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc)
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
@@ -2730,47 +2730,37 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),i,a%val(j)
write(iout,frmt) ivr(a%ia(j)),i,a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) (a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),(i),a%val(j)
write(iout,frmt) (a%ia(j)),(i),a%val(j)
end do
enddo
endif
@@ -3064,6 +3054,7 @@ subroutine psb_lc_csc_scals(d,a,info)
end subroutine psb_lc_csc_scals
function psb_lc_csc_maxval(a) result(res)
use psb_error_mod
use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_maxval
@@ -4563,10 +4554,8 @@ subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='lc_csc_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
@@ -4579,47 +4568,38 @@ subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),i,a%val(j)
write(iout,frmt) ivr(a%ia(j)),i,a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) (a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),(i),a%val(j)
write(iout,frmt) (a%ia(j)),(i),a%val(j)
end do
enddo
endif
base/serial/impl/psb_c_csr_impl.f90
+22 -38
View File
@@ -1677,6 +1677,9 @@ subroutine psb_c_csr_scals(d,a,info)
end subroutine psb_c_csr_scals
! == ===================================
!
!
@@ -2747,21 +2750,21 @@ end subroutine psb_c_csr_trim
subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc)
use psb_string_mod
use psb_c_base_mat_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_print
implicit none
integer(psb_ipk_), intent(in) :: iout
class(psb_c_csr_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer(psb_ipk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
@@ -2774,47 +2777,38 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),(a%ja(j)),a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) (i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),(a%ja(j)),a%val(j)
write(iout,frmt) (i),(a%ja(j)),a%val(j)
end do
enddo
endif
@@ -4883,9 +4877,8 @@ subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_) :: err_act
character(len=20) :: name='lc_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: irs,ics,i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general'
@@ -4898,47 +4891,38 @@ subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),(a%ja(j)),a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) (i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),(a%ja(j)),a%val(j)
write(iout,frmt) (i),(a%ja(j)),a%val(j)
end do
enddo
endif
base/serial/impl/psb_c_mat_impl.F90
+106 -4
View File
@@ -466,9 +466,9 @@ subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='sparse_print'
@@ -500,9 +500,9 @@ subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc)
character(len=*), intent(in) :: fname
class(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act, info, iout
logical :: isopen
@@ -1098,6 +1098,53 @@ subroutine psb_c_csclip(a,b,info,&
end subroutine psb_c_csclip
subroutine psb_c_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_c_base_mat_mod
use psb_c_mat_mod, psb_protect_name => psb_c_csclip_ip
implicit none
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
character(len=20) :: name='csclip'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat), allocatable :: acoo
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(acoo,stat=info)
if (info == psb_success_) then
call a%a%csclip(acoo,info,&
& imin,imax,jmin,jmax,rscale,cscale)
else
info = psb_err_alloc_dealloc_
end if
if (info == psb_success_) call a%free()
if (info == psb_success_) call move_alloc(acoo,a%a)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_csclip_ip
subroutine psb_c_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -2602,6 +2649,8 @@ subroutine psb_c_mv_from_lb(a,b)
class(psb_cspmat_type), intent(inout) :: a
class(psb_lc_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%mv_from_lfmt(b,info)
@@ -2618,6 +2667,7 @@ subroutine psb_c_cp_from_lb(a,b)
class(psb_lc_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%cp_from_lfmt(b,info)
@@ -2668,6 +2718,7 @@ subroutine psb_c_mv_from_l(a,b)
class(psb_lcspmat_type), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (allocated(b%a)) then
if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info)
call a%a%mv_from_lfmt(b%a,info)
@@ -2689,6 +2740,7 @@ subroutine psb_c_cp_from_l(a,b)
class(psb_lcspmat_type), intent(in) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (allocated(b%a)) then
if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info)
call a%a%cp_from_lfmt(b%a,info)
@@ -3845,6 +3897,53 @@ subroutine psb_lc_csclip(a,b,info,&
end subroutine psb_lc_csclip
subroutine psb_lc_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_c_base_mat_mod
use psb_c_mat_mod, psb_protect_name => psb_lc_csclip_ip
implicit none
class(psb_lcspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
character(len=20) :: name='csclip'
logical, parameter :: debug=.false.
type(psb_lc_coo_sparse_mat), allocatable :: acoo
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(acoo,stat=info)
if (info == psb_success_) then
call a%a%csclip(acoo,info,&
& imin,imax,jmin,jmax,rscale,cscale)
else
info = psb_err_alloc_dealloc_
end if
if (info == psb_success_) call a%free()
if (info == psb_success_) call move_alloc(acoo,a%a)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_lc_csclip_ip
subroutine psb_lc_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -5100,6 +5199,8 @@ subroutine psb_lc_mv_from_ib(a,b)
class(psb_lcspmat_type), intent(inout) :: a
class(psb_c_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%mv_from_ifmt(b,info)
@@ -5115,6 +5216,7 @@ subroutine psb_lc_cp_from_ib(a,b)
class(psb_c_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%cp_from_ifmt(b,info)
base/serial/impl/psb_d_coo_impl.f90 → base/serial/impl/psb_d_coo_impl.F90
+159 -40
View File
@@ -407,6 +407,38 @@ subroutine psb_d_coo_reallocate_nz(nz,a)
end subroutine psb_d_coo_reallocate_nz
subroutine psb_d_coo_ensure_size(nz,a)
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_ensure_size
use psb_error_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: nz
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
character(len=20) :: name='d_coo_ensure_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
nz_ = max(nz,ione)
call psb_ensure_size(nz_,a%ia,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%val,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_coo_ensure_size
subroutine psb_d_coo_mold(a,b,info)
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mold
use psb_error_mod
@@ -540,7 +572,44 @@ subroutine psb_d_coo_clean_zeros(a, info)
call a%trim()
end subroutine psb_d_coo_clean_zeros
subroutine psb_d_coo_clean_negidx(a,info)
use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_clean_negidx
implicit none
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_ipk_) :: nz
call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info)
if (info == 0) call a%set_nzeros(nz)
end subroutine psb_d_coo_clean_negidx
subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_clean_negidx_inner
implicit none
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
real(psb_dpk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_ipk_) :: i
info = 0
nzout = 0
do i=1, nzin
if ((ia(i)>0).and.(ja(i)>0)) then
nzout = nzout + 1
val(nzout) = val(i)
ia(nzout) = ia(i)
ja(nzout) = ja(i)
end if
end do
end subroutine psb_d_coo_clean_negidx_inner
subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_allocate_mnnz
@@ -610,17 +679,15 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_d_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
if (present(head)) write(iout,'(a,a)') '% ',head
@@ -632,38 +699,29 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
write(iout,frmt) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif
@@ -1777,7 +1835,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
else if (ctra) then !
if (alpha == done) then
i = 1
@@ -4910,6 +4968,38 @@ subroutine psb_ld_coo_reallocate_nz(nz,a)
end subroutine psb_ld_coo_reallocate_nz
subroutine psb_ld_coo_ensure_size(nz,a)
use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_ensure_size
use psb_error_mod
use psb_realloc_mod
implicit none
integer(psb_lpk_), intent(in) :: nz
class(psb_ld_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
character(len=20) :: name='ld_coo_ensure_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
nz_ = max(nz,ione)
call psb_ensure_size(nz_,a%ia,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%val,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_ld_coo_ensure_size
subroutine psb_ld_coo_mold(a,b,info)
use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mold
use psb_error_mod
@@ -5044,7 +5134,46 @@ subroutine psb_ld_coo_clean_zeros(a, info)
call a%trim()
end subroutine psb_ld_coo_clean_zeros
subroutine psb_ld_coo_clean_negidx(a,info)
use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_negidx
implicit none
class(psb_ld_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_lpk_) :: nz
call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info)
if (info == 0) call a%set_nzeros(nz)
end subroutine psb_ld_coo_clean_negidx
#if defined(IPK4) && defined(LPK8)
subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_negidx_inner
implicit none
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
real(psb_dpk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_lpk_) :: i
info = 0
nzout = 0
do i=1, nzin
if ((ia(i)>0).and.(ja(i)>0)) then
nzout = nzout + 1
val(nzout) = val(i)
ia(nzout) = ia(i)
ja(nzout) = ja(i)
end if
end do
end subroutine psb_ld_coo_clean_negidx_inner
#endif
subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz)
use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_allocate_mnnz
@@ -5123,9 +5252,8 @@ subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc)
character(len=20) :: name='ld_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
if (present(head)) write(iout,'(a,a)') '% ',head
@@ -5137,38 +5265,29 @@ subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
write(iout,frmt) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif
base/serial/impl/psb_d_csc_impl.f90
+18 -38
View File
@@ -2706,9 +2706,9 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_d_csc_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
@@ -2716,7 +2716,7 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc)
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
@@ -2730,47 +2730,37 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
frmt = psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),i,a%val(j)
write(iout,frmt) ivr(a%ia(j)),i,a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) (a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),(i),a%val(j)
write(iout,frmt) (a%ia(j)),(i),a%val(j)
end do
enddo
endif
@@ -3064,6 +3054,7 @@ subroutine psb_ld_csc_scals(d,a,info)
end subroutine psb_ld_csc_scals
function psb_ld_csc_maxval(a) result(res)
use psb_error_mod
use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_maxval
@@ -4563,10 +4554,8 @@ subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='ld_csc_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
@@ -4579,47 +4568,38 @@ subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),i,a%val(j)
write(iout,frmt) ivr(a%ia(j)),i,a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j)
write(iout,frmt) (a%ia(j)),ivc(i),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nc
do j=a%icp(i),a%icp(i+1)-1
write(iout,frmtv) (a%ia(j)),(i),a%val(j)
write(iout,frmt) (a%ia(j)),(i),a%val(j)
end do
enddo
endif
base/serial/impl/psb_d_csr_impl.f90
+22 -38
View File
@@ -1677,6 +1677,9 @@ subroutine psb_d_csr_scals(d,a,info)
end subroutine psb_d_csr_scals
! == ===================================
!
!
@@ -2747,21 +2750,21 @@ end subroutine psb_d_csr_trim
subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc)
use psb_string_mod
use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_print
implicit none
integer(psb_ipk_), intent(in) :: iout
class(psb_d_csr_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_ipk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
@@ -2774,47 +2777,38 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),(a%ja(j)),a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) (i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),(a%ja(j)),a%val(j)
write(iout,frmt) (i),(a%ja(j)),a%val(j)
end do
enddo
endif
@@ -4883,9 +4877,8 @@ subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_) :: err_act
character(len=20) :: name='ld_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: irs,ics,i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
@@ -4898,47 +4891,38 @@ subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),(a%ja(j)),a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j)
write(iout,frmt) (i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),(a%ja(j)),a%val(j)
write(iout,frmt) (i),(a%ja(j)),a%val(j)
end do
enddo
endif
base/serial/impl/psb_d_mat_impl.F90
+106 -4
View File
@@ -466,9 +466,9 @@ subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='sparse_print'
@@ -500,9 +500,9 @@ subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc)
character(len=*), intent(in) :: fname
class(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act, info, iout
logical :: isopen
@@ -1098,6 +1098,53 @@ subroutine psb_d_csclip(a,b,info,&
end subroutine psb_d_csclip
subroutine psb_d_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_d_base_mat_mod
use psb_d_mat_mod, psb_protect_name => psb_d_csclip_ip
implicit none
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
character(len=20) :: name='csclip'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat), allocatable :: acoo
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(acoo,stat=info)
if (info == psb_success_) then
call a%a%csclip(acoo,info,&
& imin,imax,jmin,jmax,rscale,cscale)
else
info = psb_err_alloc_dealloc_
end if
if (info == psb_success_) call a%free()
if (info == psb_success_) call move_alloc(acoo,a%a)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_csclip_ip
subroutine psb_d_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -2602,6 +2649,8 @@ subroutine psb_d_mv_from_lb(a,b)
class(psb_dspmat_type), intent(inout) :: a
class(psb_ld_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%mv_from_lfmt(b,info)
@@ -2618,6 +2667,7 @@ subroutine psb_d_cp_from_lb(a,b)
class(psb_ld_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%cp_from_lfmt(b,info)
@@ -2668,6 +2718,7 @@ subroutine psb_d_mv_from_l(a,b)
class(psb_ldspmat_type), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (allocated(b%a)) then
if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info)
call a%a%mv_from_lfmt(b%a,info)
@@ -2689,6 +2740,7 @@ subroutine psb_d_cp_from_l(a,b)
class(psb_ldspmat_type), intent(in) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (allocated(b%a)) then
if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info)
call a%a%cp_from_lfmt(b%a,info)
@@ -3845,6 +3897,53 @@ subroutine psb_ld_csclip(a,b,info,&
end subroutine psb_ld_csclip
subroutine psb_ld_csclip_ip(a,info,&
& imin,imax,jmin,jmax,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_d_base_mat_mod
use psb_d_mat_mod, psb_protect_name => psb_ld_csclip_ip
implicit none
class(psb_ldspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
character(len=20) :: name='csclip'
logical, parameter :: debug=.false.
type(psb_ld_coo_sparse_mat), allocatable :: acoo
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(acoo,stat=info)
if (info == psb_success_) then
call a%a%csclip(acoo,info,&
& imin,imax,jmin,jmax,rscale,cscale)
else
info = psb_err_alloc_dealloc_
end if
if (info == psb_success_) call a%free()
if (info == psb_success_) call move_alloc(acoo,a%a)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_ld_csclip_ip
subroutine psb_ld_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
@@ -5100,6 +5199,8 @@ subroutine psb_ld_mv_from_ib(a,b)
class(psb_ldspmat_type), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%mv_from_ifmt(b,info)
@@ -5115,6 +5216,7 @@ subroutine psb_ld_cp_from_ib(a,b)
class(psb_d_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_) :: info
info = psb_success_
if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info)
if (info == psb_success_) call a%a%cp_from_ifmt(b,info)
base/serial/impl/psb_s_coo_impl.f90 → base/serial/impl/psb_s_coo_impl.F90
+159 -40
View File
@@ -407,6 +407,38 @@ subroutine psb_s_coo_reallocate_nz(nz,a)
end subroutine psb_s_coo_reallocate_nz
subroutine psb_s_coo_ensure_size(nz,a)
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_ensure_size
use psb_error_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: nz
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
character(len=20) :: name='s_coo_ensure_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
nz_ = max(nz,ione)
call psb_ensure_size(nz_,a%ia,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%val,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_coo_ensure_size
subroutine psb_s_coo_mold(a,b,info)
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mold
use psb_error_mod
@@ -540,7 +572,44 @@ subroutine psb_s_coo_clean_zeros(a, info)
call a%trim()
end subroutine psb_s_coo_clean_zeros
subroutine psb_s_coo_clean_negidx(a,info)
use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_clean_negidx
implicit none
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_ipk_) :: nz
call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info)
if (info == 0) call a%set_nzeros(nz)
end subroutine psb_s_coo_clean_negidx
subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_clean_negidx_inner
implicit none
integer(psb_ipk_), intent(in) :: nzin
integer(psb_ipk_), intent(inout) :: ia(:), ja(:)
real(psb_spk_), intent(inout) :: val(:)
integer(psb_ipk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_ipk_) :: i
info = 0
nzout = 0
do i=1, nzin
if ((ia(i)>0).and.(ja(i)>0)) then
nzout = nzout + 1
val(nzout) = val(i)
ia(nzout) = ia(i)
ja(nzout) = ja(i)
end if
end do
end subroutine psb_s_coo_clean_negidx_inner
subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_allocate_mnnz
@@ -610,17 +679,15 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in) :: iout
class(psb_s_coo_sparse_mat), intent(in) :: a
integer(psb_ipk_), intent(in), optional :: iv(:)
integer(psb_lpk_), intent(in), optional :: iv(:)
character(len=*), optional :: head
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_ipk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
if (present(head)) write(iout,'(a,a)') '% ',head
@@ -632,38 +699,29 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_s_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
write(iout,frmt) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif
@@ -1777,7 +1835,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
else if (ctra) then !
if (alpha == sone) then
i = 1
@@ -4910,6 +4968,38 @@ subroutine psb_ls_coo_reallocate_nz(nz,a)
end subroutine psb_ls_coo_reallocate_nz
subroutine psb_ls_coo_ensure_size(nz,a)
use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_ensure_size
use psb_error_mod
use psb_realloc_mod
implicit none
integer(psb_lpk_), intent(in) :: nz
class(psb_ls_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
character(len=20) :: name='ls_coo_ensure_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
nz_ = max(nz,ione)
call psb_ensure_size(nz_,a%ia,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info)
if (info == psb_success_) call psb_ensure_size(nz_,a%val,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_ls_coo_ensure_size
subroutine psb_ls_coo_mold(a,b,info)
use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mold
use psb_error_mod
@@ -5044,7 +5134,46 @@ subroutine psb_ls_coo_clean_zeros(a, info)
call a%trim()
end subroutine psb_ls_coo_clean_zeros
subroutine psb_ls_coo_clean_negidx(a,info)
use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_negidx
implicit none
class(psb_ls_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_lpk_) :: nz
call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info)
if (info == 0) call a%set_nzeros(nz)
end subroutine psb_ls_coo_clean_negidx
#if defined(IPK4) && defined(LPK8)
subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info)
use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_negidx_inner
implicit none
integer(psb_lpk_), intent(in) :: nzin
integer(psb_lpk_), intent(inout) :: ia(:), ja(:)
real(psb_spk_), intent(inout) :: val(:)
integer(psb_lpk_), intent(out) :: nzout
integer(psb_ipk_), intent(out) :: info
!
!
integer(psb_lpk_) :: i
info = 0
nzout = 0
do i=1, nzin
if ((ia(i)>0).and.(ja(i)>0)) then
nzout = nzout + 1
val(nzout) = val(i)
ia(nzout) = ia(i)
ja(nzout) = ja(i)
end if
end do
end subroutine psb_ls_coo_clean_negidx_inner
#endif
subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz)
use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_allocate_mnnz
@@ -5123,9 +5252,8 @@ subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc)
character(len=20) :: name='ls_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz
character(len=80) :: frmt
integer(psb_lpk_) :: i,j, ni, nr, nc, nz
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
if (present(head)) write(iout,'(a,a)') '% ',head
@@ -5137,38 +5265,29 @@ subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc)
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
if (present(iv)) nmx = max(nmx,maxval(abs(iv)))
if (present(ivr)) nmx = max(nmx,maxval(abs(ivr)))
if (present(ivc)) nmx = max(nmx,maxval(abs(ivc)))
ni = floor(log10(1.0*nmx)) + 1
frmt = psb_ls_get_print_frmt(nr,nc,nz,iv,ivr,ivc)
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
write(iout,frmt) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif

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