fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

New L tools files matching modules.

Browse Source
ILmat
Salvatore Filippone 8 years ago
parent 6d9d8daa5c
commit 7679e23f50
5 changed files with 2179 additions and 7 deletions
Show Stats Download Patch File Download Diff File

13
base/tools/Makefile
Unescape Escape View File

@ -1,18 +1,17 @@
include ../../Make.inc
FOBJS = psb_sallc.o psb_sasb.o \
psb_sfree.o psb_sins.o \
psb_dallc.o psb_dasb.o \
psb_dfree.o psb_dins.o \
psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \
FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \
psb_cdren.o psb_cdrep.o psb_get_overlap.o psb_cd_lstext.o\
psb_cdcpy.o psb_cd_reinit.o psb_cd_switch_ovl_indxmap.o \
psb_dspalloc.o psb_dspasb.o \
psb_dspfree.o psb_dspins.o psb_dsprn.o \
psb_sspalloc.o psb_sspasb.o \
psb_sspfree.o psb_sspins.o psb_ssprn.o\
psb_glob_to_loc.o psb_iallc.o psb_iasb.o \
psb_ifree.o psb_iins.o psb_loc_to_glob.o\
psb_glob_to_loc.o psb_loc_to_glob.o\
psb_iallc.o psb_iasb.o psb_ifree.o psb_iins.o \
psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \
psb_sallc.o psb_sasb.o psb_sfree.o psb_sins.o \
psb_dallc.o psb_dasb.o psb_dfree.o psb_dins.o \
psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \
psb_zspalloc.o psb_zspasb.o psb_zspfree.o\
psb_zspins.o psb_zsprn.o \

516
base/tools/psb_lallc.f90
Unescape Escape View File

@ -0,0 +1,516 @@
!
! 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_lallc.f90
!
! Function: psb_lalloc
! Allocates dense matrix for PSBLAS routines.
! The descriptor may be in either the build or assembled state.
!
! Arguments:
! x - the matrix to be allocated.
! desc_a - the communication descriptor.
! info - Return code
! n - optional number of columns.
! lb - optional lower bound on column indices
subroutine psb_lalloc(x, desc_a, info, n, lb)
use psb_base_mod, psb_protect_name => psb_lalloc
use psi_mod
implicit none
!....parameters...
integer(psb_lpk_), 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
!locals
integer(psb_ipk_) :: np,me,err,nr,i,j,err_act
integer(psb_ipk_) :: ictxt,n_
integer(psb_ipk_) :: int_err(5),exch(3)
character(len=20) :: name
name='psb_geall'
if(psb_get_errstatus() /= 0) return
info=psb_success_
err=0
int_err(1)=0
call psb_erractionsave(err_act)
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
!... check m and n parameters....
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
if (present(n)) then
n_ = n
else
n_ = 1
endif
!global check on n parameters
if (me == psb_root_) then
exch(1)=n_
call psb_bcast(ictxt,exch(1),root=psb_root_)
else
call psb_bcast(ictxt,exch(1),root=psb_root_)
if (exch(1) /= n_) then
info=psb_err_parm_differs_among_procs_
int_err(1)=1
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,n_,x,info,lb2=lb)
if (info /= psb_success_) then
info=psb_err_alloc_request_
int_err(1)=nr*n_
call psb_errpush(info,name,int_err,a_err='integer(psb_lpk_)')
goto 9999
endif
x(:,:) = lzero
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lalloc
!!$
!!$ 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.
!!$
!!$
!
! Function: psb_lallocv
! Allocates dense matrix for PSBLAS routines
! The descriptor may be in either the build or assembled state.
!
! Arguments:
! x(:) - the matrix to be allocated.
! desc_a - the communication descriptor.
! info - return code
subroutine psb_lallocv(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_lallocv
use psi_mod
implicit none
!....parameters...
integer(psb_lpk_), 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
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act
integer(psb_ipk_) :: ictxt, int_err(5)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,x,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='integer(psb_lpk_)')
goto 9999
endif
x(:) = lzero
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lallocv
subroutine psb_lalloc_vect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_lalloc_vect
use psi_mod
implicit none
!....parameters...
type(psb_l_vect_type), intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act
integer(psb_ipk_) :: ictxt, int_err(5)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then
nr = max(1,desc_a%get_local_cols())
else if (psb_is_bld_desc(desc_a)) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
allocate(psb_l_base_vect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,info)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
call x%zero()
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lalloc_vect
subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb)
use psb_base_mod, psb_protect_name => psb_lalloc_vect_r2
use psi_mod
implicit none
!....parameters...
type(psb_l_vect_type), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n,lb
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_
integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
if (present(n)) then
n_ = n
else
n_ = 1
endif
if (present(lb)) then
lb_ = lb
else
lb_ = 1
endif
!global check on n parameters
if (me == psb_root_) then
exch(1)=n_
call psb_bcast(ictxt,exch(1),root=psb_root_)
else
call psb_bcast(ictxt,exch(1),root=psb_root_)
if (exch(1) /= n_) then
info=psb_err_parm_differs_among_procs_
int_err(1)=1
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
allocate(x(lb_:lb_+n_-1), stat=info)
if (info == 0) then
do i=lb_, lb_+n_-1
allocate(psb_l_base_vect_type :: x(i)%v, stat=info)
if (info == 0) call x(i)%all(nr,info)
if (info == 0) call x(i)%zero()
if (info /= 0) exit
end do
end if
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lalloc_vect_r2
subroutine psb_lalloc_multivect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_lalloc_multivect
use psi_mod
implicit none
!....parameters...
type(psb_l_multivect_type), allocatable, intent(out) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n
!locals
integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_
integer(psb_ipk_) :: ictxt, int_err(5), exch(1)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
name='psb_geall'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check m and n parameters....
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
if (present(n)) then
n_ = n
else
n_ = 1
endif
!global check on n parameters
if (me == psb_root_) then
exch(1)=n_
call psb_bcast(ictxt,exch(1),root=psb_root_)
else
call psb_bcast(ictxt,exch(1),root=psb_root_)
if (exch(1) /= n_) then
info=psb_err_parm_differs_among_procs_
int_err(1)=1
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
! As this is a rank-1 array, optional parameter N is actually ignored.
!....allocate x .....
if (desc_a%is_asb().or.desc_a%is_upd()) then
nr = max(1,desc_a%get_local_cols())
else if (desc_a%is_bld()) then
nr = max(1,desc_a%get_local_rows())
else
info = psb_err_internal_error_
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
allocate(psb_l_base_multivect_type :: x%v, stat=info)
if (info == 0) call x%all(nr,n_,info)
if (info == 0) call x%zero()
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lalloc_multivect

504
base/tools/psb_lasb.f90
Unescape Escape View File

@ -0,0 +1,504 @@
!
! 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_lasb.f90
!
! Subroutine: psb_lasb
! Assembles a dense matrix for PSBLAS routines
! Since the allocation may have been called with the desciptor
! in the build state we make sure that X has a number of rows
! allowing for the halo indices, reallocating if necessary.
! We also call the halo routine for good measure.
!
! Arguments:
! x(:,:) - integer, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
subroutine psb_lasb(x, desc_a, info, scratch)
use psb_base_mod, psb_protect_name => psb_lasb
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), allocatable, intent(inout) :: x(:,:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act
integer(psb_ipk_) :: i1sz, i2sz
integer(psb_ipk_) :: debug_level, debug_unit
logical :: scratch_
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=psb_success_
name='psb_lgeasb_m'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': start: ',np,&
& desc_a%get_dectype()
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.psb_is_asb_desc(desc_a)) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' error '
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
! check size
ictxt = desc_a%get_context()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
i1sz = size(x,dim=1)
i2sz = size(x,dim=2)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol
if (i1sz < ncol) then
call psb_realloc(ncol,i2sz,x,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
endif
endif
if (.not.scratch_) then
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lasb
!!$
!!$ 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_lasb
! Assembles a dense matrix for PSBLAS routines
! Since the allocation may have been called with the desciptor
! in the build state we make sure that X has a number of rows
! allowing for the halo indices, reallocating if necessary.
! We also call the halo routine for good measure.
!
! Arguments:
! x(:) - integer, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_lasbv(x, desc_a, info, scratch)
use psb_base_mod, psb_protect_name => psb_lasbv
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act
integer(psb_ipk_) :: debug_level, debug_unit
logical :: scratch_
character(len=20) :: name,ch_err
info = psb_success_
int_err(1) = 0
name = 'psb_lgeasb_v'
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.psb_is_asb_desc(desc_a)) then
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
i1sz = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol
if (i1sz < ncol) then
call psb_realloc(ncol,x,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
endif
endif
if (.not.scratch_) then
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='f90_pshalo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lasbv
subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_lasb_vect
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
info = psb_success_
if (psb_errstatus_fatal()) return
int_err(1) = 0
name = 'psb_lgeasb_v'
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
if (present(mold)) then
call x%cnv(mold)
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lasb_vect
subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_lasb_vect_r2
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_l_vect_type), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me, i, n
integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
info = psb_success_
if (psb_errstatus_fatal()) return
int_err(1) = 0
name = 'psb_lgeasb_v'
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
n = size(x)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
call x(i)%asb(ncol,info)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
if (present(mold)) then
call x(i)%cnv(mold)
end if
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lasb_vect_r2
subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n)
use psb_base_mod, psb_protect_name => psb_lasb_multivect
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_l_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_), optional, intent(in) :: n
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_
logical :: scratch_
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name,ch_err
info = psb_success_
if (psb_errstatus_fatal()) return
int_err(1) = 0
name = 'psb_lgeasb'
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
if (present(n)) then
n_ = n
else
if (allocated(x%v)) then
n_ = x%v%get_ncols()
else
n_ = 1
end if
endif
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
else if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
if (scratch_) then
call x%free(info)
call x%bld(ncol,n_,mold=mold)
else
call x%asb(ncol,n_,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
if (present(mold)) then
call x%cnv(mold)
end if
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lasb_multivect

322
base/tools/psb_lfree.f90
Unescape Escape View File

@ -0,0 +1,322 @@
!
! 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_lfree.f90
!
! Subroutine: psb_lfree
! frees a dense matrix structure
!
! Arguments:
! x(:,:) - integer, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_lfree(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_lfree
implicit none
!....parameters...
integer(psb_lpk_),allocatable, intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name='psb_lfree'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
end if
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
deallocate(x,stat=info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lfree
! Subroutine: psb_lfreev
! frees a dense matrix structure
!
! Arguments:
! x(:) - integer, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_lfreev(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_lfreev
implicit none
!....parameters...
integer(psb_lpk_),allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name='psb_lfreev'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
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 (.not.allocated(x)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
deallocate(x,stat=info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lfreev
subroutine psb_lfree_vect(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_lfree_vect
implicit none
!....parameters...
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act)
name='psb_lfreev'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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 (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
call x%free(info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lfree_vect
subroutine psb_lfree_vect_r2(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_lfree_vect_r2
implicit none
!....parameters...
type(psb_l_vect_type), allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act, i
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act)
name='psb_lfreev'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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
do i=lbound(x,1),ubound(x,1)
call x(i)%free(info)
if (info /= 0) exit
end do
if (info == 0) deallocate(x,stat=info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lfree_vect_r2
subroutine psb_lfree_multivect(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_lfree_multivect
implicit none
!....parameters...
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
character(len=20) :: name
info=psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act)
name='psb_lfree'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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 (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
call x%free(info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lfree_multivect

831
base/tools/psb_lins.f90
Unescape Escape View File

@ -0,0 +1,831 @@
!
! 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: psb_linsvi
! Insert dense submatrix to dense matrix. Note: the row indices in IRW
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process are silently discarded.
!
! Arguments:
! m - integer. Number of rows of submatrix belonging to
! val to be inserted.
! irw(:) - integer Row indices of rows of val (global numbering)
! val(:) - integer The source dense submatrix.
! x(:) - integer The destination dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_linsvi(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_linsvi
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:)
integer(psb_lpk_),intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_linsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
return
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
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1) < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all val's rows
! row actual block row
if (irl(i) > 0) then
! this row belongs to me
! copy i-th row of block val in x
x(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all val's rows
if (irl(i) > 0) then
! this row belongs to me
! copy i-th row of block val in x
x(irl(i)) = x(irl(i)) + val(i)
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_linsvi
subroutine psb_lins_vect(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_lins_vect
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:)
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_linsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,dupl_,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lins_vect
subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_lins_vect_v
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
type(psb_i_vect_type), intent(inout) :: irw
type(psb_l_vect_type), intent(inout) :: val
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
integer(psb_lpk_), allocatable :: lval(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_linsvi_vect_v'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
call x%ins(m,irw,val,dupl_,info)
else
irl = irw%get_vect()
lval = val%get_vect()
call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.)
call x%ins(m,irl,lval,dupl_,info)
end if
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lins_vect_v
subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_lins_vect_r2
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:,:)
type(psb_l_vect_type), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5), n
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_linsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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 (.not.allocated(x(1)%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x(1)%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
n = min(size(x),size(val,2))
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit
end do
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lins_vect_r2
!!$
!!$ 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_linsi
! Insert dense submatrix to dense matrix. Note: the row indices in IRW
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process are silently discarded.
!
! Arguments:
! m - integer. Number of rows of submatrix belonging to
! val to be inserted.
! irw(:) - integer Row indices of rows of val (global numbering)
! val(:,:) - integer The source dense submatrix.
! x(:,:) - integer The destination dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
! dupl - integer What to do with duplicates:
! psb_dupl_ovwrt_ overwrite
! psb_dupl_add_ add
subroutine psb_linsi(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_linsi
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:,:)
integer(psb_lpk_),intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,loc_row,j,n,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np,me,dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_linsi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
return
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
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1) < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
n = min(size(val,2),size(x,2))
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all val's rows
! row actual block row
loc_row = irl(i)
if (loc_row > 0) then
! this row belongs to me
! copy i-th row of block val in x
do j=1,n
x(loc_row,j) = val(i,j)
end do
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all val's rows
! row actual block row
loc_row = irl(i)
if (loc_row > 0) then
! this row belongs to me
! copy i-th row of block val in x
do j=1,n
x(loc_row,j) = x(loc_row,j) + val(i,j)
end do
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_linsi
subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_lins_multivect
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: irw(:)
integer(psb_lpk_), intent(in) :: val(:,:)
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_linsvi'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
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
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
allocate(irl(m),stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
irl(1:m) = irw(1:m)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
call x%ins(m,irl,val,dupl_,info)
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
deallocate(irl)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_lins_multivect
Write Preview
Loading…
Cancel
Save