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

Merge branch 'development' of https://github.com/sfilippone/psblas3 into development

Browse Source
mat-allocate
Salvatore Filippone 4 years ago
parent 7b133657d4 c0c8224253
commit b7926336ac
32 changed files with 1148 additions and 428 deletions
Show Stats Download Patch File Download Diff File

21
base/modules/serial/psb_c_base_vect_mod.f90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_c_base_vect_mod
procedure, pass(x) :: set_scal => c_base_set_scal
procedure, pass(x) :: set_vect => c_base_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: get_entry=> c_base_get_entry
!
! Gather/scatter. These are needed for MPI interfacing.
! May have to be reworked.
@ -855,6 +856,26 @@ contains
end subroutine c_base_set_vect
!
! Get entry.
!
!
!> Function base_get_entry
!! \memberof psb_c_base_vect_type
!! \brief Get one entry from the vector
!!
!
function c_base_get_entry(x, index) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
complex(psb_spk_) :: res
res = 0
if (allocated(x%v)) res = x%v(index)
end function c_base_get_entry
!
! Overwrite with absolute value
!

11
base/modules/serial/psb_c_vect_mod.F90
Unescape Escape View File

@ -80,6 +80,8 @@ module psb_c_vect_mod
procedure, pass(x) :: set_dev => c_vect_set_dev
procedure, pass(x) :: set_sync => c_vect_set_sync
procedure, pass(x) :: get_entry => c_vect_get_entry
procedure, pass(x) :: dot_v => c_vect_dot_v
procedure, pass(x) :: dot_a => c_vect_dot_a
generic, public :: dot => dot_v, dot_a
@ -603,6 +605,15 @@ contains
end function c_vect_is_dev
function c_vect_get_entry(x,index) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
complex(psb_spk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_entry(index)
end function c_vect_get_entry
function c_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_c_vect_type), intent(inout) :: x, y

21
base/modules/serial/psb_d_base_vect_mod.f90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_d_base_vect_mod
procedure, pass(x) :: set_scal => d_base_set_scal
procedure, pass(x) :: set_vect => d_base_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: get_entry=> d_base_get_entry
!
! Gather/scatter. These are needed for MPI interfacing.
! May have to be reworked.
@ -862,6 +863,26 @@ contains
end subroutine d_base_set_vect
!
! Get entry.
!
!
!> Function base_get_entry
!! \memberof psb_d_base_vect_type
!! \brief Get one entry from the vector
!!
!
function d_base_get_entry(x, index) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
real(psb_dpk_) :: res
res = 0
if (allocated(x%v)) res = x%v(index)
end function d_base_get_entry
!
! Overwrite with absolute value
!

11
base/modules/serial/psb_d_vect_mod.F90
Unescape Escape View File

@ -80,6 +80,8 @@ module psb_d_vect_mod
procedure, pass(x) :: set_dev => d_vect_set_dev
procedure, pass(x) :: set_sync => d_vect_set_sync
procedure, pass(x) :: get_entry => d_vect_get_entry
procedure, pass(x) :: dot_v => d_vect_dot_v
procedure, pass(x) :: dot_a => d_vect_dot_a
generic, public :: dot => dot_v, dot_a
@ -610,6 +612,15 @@ contains
end function d_vect_is_dev
function d_vect_get_entry(x,index) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
real(psb_dpk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_entry(index)
end function d_vect_get_entry
function d_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_d_vect_type), intent(inout) :: x, y

1
base/modules/serial/psb_i_base_vect_mod.f90
Unescape Escape View File

@ -793,7 +793,6 @@ contains
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!

1
base/modules/serial/psb_l_base_vect_mod.f90
Unescape Escape View File

@ -794,7 +794,6 @@ contains
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!

21
base/modules/serial/psb_s_base_vect_mod.f90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_s_base_vect_mod
procedure, pass(x) :: set_scal => s_base_set_scal
procedure, pass(x) :: set_vect => s_base_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: get_entry=> s_base_get_entry
!
! Gather/scatter. These are needed for MPI interfacing.
! May have to be reworked.
@ -862,6 +863,26 @@ contains
end subroutine s_base_set_vect
!
! Get entry.
!
!
!> Function base_get_entry
!! \memberof psb_s_base_vect_type
!! \brief Get one entry from the vector
!!
!
function s_base_get_entry(x, index) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
real(psb_spk_) :: res
res = 0
if (allocated(x%v)) res = x%v(index)
end function s_base_get_entry
!
! Overwrite with absolute value
!

11
base/modules/serial/psb_s_vect_mod.F90
Unescape Escape View File

@ -80,6 +80,8 @@ module psb_s_vect_mod
procedure, pass(x) :: set_dev => s_vect_set_dev
procedure, pass(x) :: set_sync => s_vect_set_sync
procedure, pass(x) :: get_entry => s_vect_get_entry
procedure, pass(x) :: dot_v => s_vect_dot_v
procedure, pass(x) :: dot_a => s_vect_dot_a
generic, public :: dot => dot_v, dot_a
@ -610,6 +612,15 @@ contains
end function s_vect_is_dev
function s_vect_get_entry(x,index) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
real(psb_spk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_entry(index)
end function s_vect_get_entry
function s_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_s_vect_type), intent(inout) :: x, y

21
base/modules/serial/psb_z_base_vect_mod.f90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_z_base_vect_mod
procedure, pass(x) :: set_scal => z_base_set_scal
procedure, pass(x) :: set_vect => z_base_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: get_entry=> z_base_get_entry
!
! Gather/scatter. These are needed for MPI interfacing.
! May have to be reworked.
@ -855,6 +856,26 @@ contains
end subroutine z_base_set_vect
!
! Get entry.
!
!
!> Function base_get_entry
!! \memberof psb_z_base_vect_type
!! \brief Get one entry from the vector
!!
!
function z_base_get_entry(x, index) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
complex(psb_dpk_) :: res
res = 0
if (allocated(x%v)) res = x%v(index)
end function z_base_get_entry
!
! Overwrite with absolute value
!

11
base/modules/serial/psb_z_vect_mod.F90
Unescape Escape View File

@ -80,6 +80,8 @@ module psb_z_vect_mod
procedure, pass(x) :: set_dev => z_vect_set_dev
procedure, pass(x) :: set_sync => z_vect_set_sync
procedure, pass(x) :: get_entry => z_vect_get_entry
procedure, pass(x) :: dot_v => z_vect_dot_v
procedure, pass(x) :: dot_a => z_vect_dot_a
generic, public :: dot => dot_v, dot_a
@ -603,6 +605,15 @@ contains
end function z_vect_is_dev
function z_vect_get_entry(x,index) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_), intent(in) :: index
complex(psb_dpk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_entry(index)
end function z_vect_get_entry
function z_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_z_vect_type), intent(inout) :: x, y

11
base/modules/tools/psb_c_tools_mod.F90
Unescape Escape View File

@ -37,6 +37,7 @@ Module psb_c_tools_mod
& 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
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_calloc_vect(x, desc_a,info)
@ -419,6 +420,16 @@ Module psb_c_tools_mod
end subroutine psb_c_simple_glob_transpose_ip
end interface psb_glob_transpose
interface psb_getelem
function psb_c_getelem(x,index,desc_a,info) result(res)
import
type(psb_c_vect_type), intent(inout) :: x
integer(psb_lpk_), intent(in) :: index
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: res
end function
end interface
end module psb_c_tools_mod

11
base/modules/tools/psb_d_tools_mod.F90
Unescape Escape View File

@ -37,6 +37,7 @@ Module psb_d_tools_mod
& 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
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_dalloc_vect(x, desc_a,info)
@ -419,6 +420,16 @@ Module psb_d_tools_mod
end subroutine psb_d_simple_glob_transpose_ip
end interface psb_glob_transpose
interface psb_getelem
function psb_d_getelem(x,index,desc_a,info) result(res)
import
type(psb_d_vect_type), intent(inout) :: x
integer(psb_lpk_), intent(in) :: index
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: res
end function
end interface
end module psb_d_tools_mod

1
base/modules/tools/psb_i_tools_mod.F90
Unescape Escape View File

@ -34,6 +34,7 @@ Module psb_i_tools_mod
use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type
use psb_l_vect_mod, only : psb_l_vect_type
use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_ialloc_vect(x, desc_a,info)

1
base/modules/tools/psb_l_tools_mod.F90
Unescape Escape View File

@ -34,6 +34,7 @@ Module psb_l_tools_mod
use psb_l_vect_mod, only : psb_l_base_vect_type, psb_l_vect_type
! use psb_i_vect_mod, only : psb_i_vect_type
use psb_l_multivect_mod, only : psb_l_base_multivect_type, psb_l_multivect_type
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_lalloc_vect(x, desc_a,info)

11
base/modules/tools/psb_s_tools_mod.F90
Unescape Escape View File

@ -37,6 +37,7 @@ Module psb_s_tools_mod
& 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
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_salloc_vect(x, desc_a,info)
@ -419,6 +420,16 @@ Module psb_s_tools_mod
end subroutine psb_s_simple_glob_transpose_ip
end interface psb_glob_transpose
interface psb_getelem
function psb_s_getelem(x,index,desc_a,info) result(res)
import
type(psb_s_vect_type), intent(inout) :: x
integer(psb_lpk_), intent(in) :: index
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: res
end function
end interface
end module psb_s_tools_mod

11
base/modules/tools/psb_z_tools_mod.F90
Unescape Escape View File

@ -37,6 +37,7 @@ Module psb_z_tools_mod
& 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
use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem
interface psb_geall
subroutine psb_zalloc_vect(x, desc_a,info)
@ -419,6 +420,16 @@ Module psb_z_tools_mod
end subroutine psb_z_simple_glob_transpose_ip
end interface psb_glob_transpose
interface psb_getelem
function psb_z_getelem(x,index,desc_a,info) result(res)
import
type(psb_z_vect_type), intent(inout) :: x
integer(psb_lpk_), intent(in) :: index
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: res
end function
end interface
end module psb_z_tools_mod

3
base/tools/Makefile
Unescape Escape View File

@ -26,7 +26,8 @@ FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt
psb_cspins.o psb_csprn.o psb_cd_set_bld.o \
psb_s_map.o psb_d_map.o psb_c_map.o psb_z_map.o \
psb_s_par_csr_spspmm.o psb_d_par_csr_spspmm.o psb_c_par_csr_spspmm.o psb_z_par_csr_spspmm.o \
psb_s_glob_transpose.o psb_d_glob_transpose.o psb_c_glob_transpose.o psb_z_glob_transpose.o
psb_s_glob_transpose.o psb_d_glob_transpose.o psb_c_glob_transpose.o psb_z_glob_transpose.o \
psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o
# psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \
MPFOBJS = psb_icdasb.o psb_ssphalo.o psb_dsphalo.o psb_csphalo.o psb_zsphalo.o \

103
base/tools/psb_cgetelem.f90
Unescape Escape View File

@ -0,0 +1,103 @@
!
! 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.
!
! Function: psb_c_getelem
! Extract entries from a dense vector. Note: the row indices in index
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process have to be in the halo,
! othewise failure is ensured.
!
! Arguments:
! x - type(psb_c_vect_type) The source vector
! desc_a - type(psb_desc_type). The communication descriptor.
! index - integer. Row index of x of the value to extract
! iam - integer. Index of the process requesting the value
! info - integer. return code
function psb_c_getelem(x,index,desc_a,info) result(res)
use psb_base_mod, psb_protect_name => psb_c_getelem
use psi_mod
implicit none
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(in) :: index
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: res
!locals
integer(psb_ipk_) :: localindex(1)
integer(psb_ipk_) :: ictxt, np, me, err_act
integer(psb_lpk_) :: gindex(1)
integer(psb_lpk_), allocatable :: myidx(:),mylocal(:)
character(len=20) :: name
logical, parameter :: debug = .false.
gindex(1) = index
res = -1.0
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_c_getelem'
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
call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.)
if(debug.and.(localindex(1) < 1)) then
write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex
myidx = desc_a%get_global_indices(owned=.false.)
mylocal = desc_a%get_global_indices(owned=.true.)
write(*,*)"My (local+halo) indexes are: ",myidx
write(*,*)"My (local) indexes are: ",mylocal
end if
res = x%get_entry(localindex(1))
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end function

103
base/tools/psb_dgetelem.f90
Unescape Escape View File

@ -0,0 +1,103 @@
!
! 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.
!
! Function: psb_d_getelem
! Extract entries from a dense vector. Note: the row indices in index
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process have to be in the halo,
! othewise failure is ensured.
!
! Arguments:
! x - type(psb_d_vect_type) The source vector
! desc_a - type(psb_desc_type). The communication descriptor.
! index - integer. Row index of x of the value to extract
! iam - integer. Index of the process requesting the value
! info - integer. return code
function psb_d_getelem(x,index,desc_a,info) result(res)
use psb_base_mod, psb_protect_name => psb_d_getelem
use psi_mod
implicit none
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(in) :: index
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: res
!locals
integer(psb_ipk_) :: localindex(1)
integer(psb_ipk_) :: ictxt, np, me, err_act
integer(psb_lpk_) :: gindex(1)
integer(psb_lpk_), allocatable :: myidx(:),mylocal(:)
character(len=20) :: name
logical, parameter :: debug = .false.
gindex(1) = index
res = -1.0
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_d_getelem'
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
call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.)
if(debug.and.(localindex(1) < 1)) then
write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex
myidx = desc_a%get_global_indices(owned=.false.)
mylocal = desc_a%get_global_indices(owned=.true.)
write(*,*)"My (local+halo) indexes are: ",myidx
write(*,*)"My (local) indexes are: ",mylocal
end if
res = x%get_entry(localindex(1))
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end function

103
base/tools/psb_sgetelem.f90
Unescape Escape View File

@ -0,0 +1,103 @@
!
! 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.
!
! Function: psb_s_getelem
! Extract entries from a dense vector. Note: the row indices in index
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process have to be in the halo,
! othewise failure is ensured.
!
! Arguments:
! x - type(psb_s_vect_type) The source vector
! desc_a - type(psb_desc_type). The communication descriptor.
! index - integer. Row index of x of the value to extract
! iam - integer. Index of the process requesting the value
! info - integer. return code
function psb_s_getelem(x,index,desc_a,info) result(res)
use psb_base_mod, psb_protect_name => psb_s_getelem
use psi_mod
implicit none
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(in) :: index
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: res
!locals
integer(psb_ipk_) :: localindex(1)
integer(psb_ipk_) :: ictxt, np, me, err_act
integer(psb_lpk_) :: gindex(1)
integer(psb_lpk_), allocatable :: myidx(:),mylocal(:)
character(len=20) :: name
logical, parameter :: debug = .false.
gindex(1) = index
res = -1.0
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_s_getelem'
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
call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.)
if(debug.and.(localindex(1) < 1)) then
write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex
myidx = desc_a%get_global_indices(owned=.false.)
mylocal = desc_a%get_global_indices(owned=.true.)
write(*,*)"My (local+halo) indexes are: ",myidx
write(*,*)"My (local) indexes are: ",mylocal
end if
res = x%get_entry(localindex(1))
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end function

103
base/tools/psb_zgetelem.f90
Unescape Escape View File

@ -0,0 +1,103 @@
!
! 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.
!
! Function: psb_z_getelem
! Extract entries from a dense vector. Note: the row indices in index
! are assumed to be in global numbering and are converted on the fly.
! Row indices not belonging to the current process have to be in the halo,
! othewise failure is ensured.
!
! Arguments:
! x - type(psb_z_vect_type) The source vector
! desc_a - type(psb_desc_type). The communication descriptor.
! index - integer. Row index of x of the value to extract
! iam - integer. Index of the process requesting the value
! info - integer. return code
function psb_z_getelem(x,index,desc_a,info) result(res)
use psb_base_mod, psb_protect_name => psb_z_getelem
use psi_mod
implicit none
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(in) :: index
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: res
!locals
integer(psb_ipk_) :: localindex(1)
integer(psb_ipk_) :: ictxt, np, me, err_act
integer(psb_lpk_) :: gindex(1)
integer(psb_lpk_), allocatable :: myidx(:),mylocal(:)
character(len=20) :: name
logical, parameter :: debug = .false.
gindex(1) = index
res = -1.0
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_z_getelem'
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
call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.)
if(debug.and.(localindex(1) < 1)) then
write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex
myidx = desc_a%get_global_indices(owned=.false.)
mylocal = desc_a%get_global_indices(owned=.true.)
write(*,*)"My (local+halo) indexes are: ",myidx
write(*,*)"My (local) indexes are: ",mylocal
end if
res = x%get_entry(localindex(1))
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end function

1
cbind/base/psb_c_base.h
Unescape Escape View File

@ -90,7 +90,6 @@ extern "C" {
psb_i_t psb_c_cd_get_local_rows(psb_c_descriptor *cd);
psb_i_t psb_c_cd_get_local_cols(psb_c_descriptor *cd);
psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd);
psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd);
psb_i_t psb_c_cd_get_global_indices(psb_l_t idx[], psb_i_t nidx, bool owned, psb_c_descriptor *cd);
/* legal values for upd argument */

1
cbind/base/psb_c_cbase.h
Unescape Escape View File

@ -30,6 +30,7 @@ psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val,
psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgeasb(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh);
psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_cspmat* psb_c_new_cspmat();

1
cbind/base/psb_c_dbase.h
Unescape Escape View File

@ -30,6 +30,7 @@ psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val,
psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh);
psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_dspmat* psb_c_new_dspmat();

1
cbind/base/psb_c_sbase.h
Unescape Escape View File

@ -30,6 +30,7 @@ psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val,
psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh);
psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_sspmat* psb_c_new_sspmat();

35
cbind/base/psb_c_tools_cbind_mod.F90
Unescape Escape View File

@ -398,6 +398,39 @@ contains
!!$ return
!!$ end function psb_c_cspprint
function psb_c_cgetelem(xh,index,cdh) bind(c) result(res)
implicit none
end module psb_c_tools_cbind_mod
type(psb_c_cvector) :: xh
integer(psb_c_lpk_), value :: index
type(psb_c_descriptor) :: cdh
complex(c_float_complex) :: res
type(psb_c_vect_type), pointer :: xp
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info, ixb
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
ixb = psb_c_get_index_base()
if (ixb == 1) then
res = psb_getelem(xp,index,descp,info)
else
res = psb_getelem(xp,index+(1-ixb),descp,info)
end if
return
end function psb_c_cgetelem
end module psb_c_tools_cbind_mod

1
cbind/base/psb_c_zbase.h
Unescape Escape View File

@ -30,6 +30,7 @@ psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val,
psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgeasb(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh);
psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd);
/* sparse matrices*/
psb_c_zspmat* psb_c_new_zspmat();

35
cbind/base/psb_d_tools_cbind_mod.F90
Unescape Escape View File

@ -398,6 +398,39 @@ contains
!!$ return
!!$ end function psb_c_dspprint
function psb_c_dgetelem(xh,index,cdh) bind(c) result(res)
implicit none
end module psb_d_tools_cbind_mod
type(psb_c_dvector) :: xh
integer(psb_c_lpk_), value :: index
type(psb_c_descriptor) :: cdh
real(c_double) :: res
type(psb_d_vect_type), pointer :: xp
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info, ixb
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
ixb = psb_c_get_index_base()
if (ixb == 1) then
res = psb_getelem(xp,index,descp,info)
else
res = psb_getelem(xp,index+(1-ixb),descp,info)
end if
return
end function psb_c_dgetelem
end module psb_d_tools_cbind_mod

35
cbind/base/psb_s_tools_cbind_mod.F90
Unescape Escape View File

@ -398,6 +398,39 @@ contains
!!$ return
!!$ end function psb_c_sspprint
function psb_c_sgetelem(xh,index,cdh) bind(c) result(res)
implicit none
end module psb_s_tools_cbind_mod
type(psb_c_svector) :: xh
integer(psb_c_lpk_), value :: index
type(psb_c_descriptor) :: cdh
real(c_float) :: res
type(psb_s_vect_type), pointer :: xp
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info, ixb
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
ixb = psb_c_get_index_base()
if (ixb == 1) then
res = psb_getelem(xp,index,descp,info)
else
res = psb_getelem(xp,index+(1-ixb),descp,info)
end if
return
end function psb_c_sgetelem
end module psb_s_tools_cbind_mod

35
cbind/base/psb_z_tools_cbind_mod.F90
Unescape Escape View File

@ -398,6 +398,39 @@ contains
!!$ return
!!$ end function psb_c_zspprint
function psb_c_zgetelem(xh,index,cdh) bind(c) result(res)
implicit none
end module psb_z_tools_cbind_mod
type(psb_c_zvector) :: xh
integer(psb_c_lpk_), value :: index
type(psb_c_descriptor) :: cdh
complex(c_double_complex) :: res
type(psb_z_vect_type), pointer :: xp
type(psb_desc_type), pointer :: descp
integer(psb_c_ipk_) :: info, ixb
res = -1
if (c_associated(cdh%item)) then
call c_f_pointer(cdh%item,descp)
else
return
end if
if (c_associated(xh%item)) then
call c_f_pointer(xh%item,xp)
else
return
end if
ixb = psb_c_get_index_base()
if (ixb == 1) then
res = psb_getelem(xp,index,descp,info)
else
res = psb_getelem(xp,index+(1-ixb),descp,info)
end if
return
end function psb_c_zgetelem
end module psb_z_tools_cbind_mod

Write Preview
Loading…
Cancel
Save