From 624a07a25b7f069aeb7ad3f896ef31852eb7afda Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 24 Sep 2020 12:40:13 +0200 Subject: [PATCH] Added getelem function to retrieve entries from distributed vectors --- base/modules/serial/psb_c_base_vect_mod.f90 | 21 +++ base/modules/serial/psb_c_vect_mod.F90 | 17 +- base/modules/serial/psb_d_base_vect_mod.f90 | 21 +++ base/modules/serial/psb_d_vect_mod.F90 | 17 +- base/modules/serial/psb_i_base_vect_mod.f90 | 1 - base/modules/serial/psb_i_vect_mod.F90 | 6 +- base/modules/serial/psb_l_base_vect_mod.f90 | 1 - base/modules/serial/psb_l_vect_mod.F90 | 6 +- base/modules/serial/psb_s_base_vect_mod.f90 | 21 +++ base/modules/serial/psb_s_vect_mod.F90 | 17 +- base/modules/serial/psb_z_base_vect_mod.f90 | 21 +++ base/modules/serial/psb_z_vect_mod.F90 | 17 +- base/modules/tools/psb_c_tools_mod.F90 | 41 ++-- base/modules/tools/psb_d_tools_mod.F90 | 41 ++-- base/modules/tools/psb_i_tools_mod.F90 | 17 +- base/modules/tools/psb_l_tools_mod.F90 | 17 +- base/modules/tools/psb_s_tools_mod.F90 | 41 ++-- base/modules/tools/psb_z_tools_mod.F90 | 41 ++-- base/tools/Makefile | 7 +- base/tools/psb_cgetelem.f90 | 103 ++++++++++ base/tools/psb_dgetelem.f90 | 103 ++++++++++ base/tools/psb_sgetelem.f90 | 103 ++++++++++ base/tools/psb_zgetelem.f90 | 103 ++++++++++ cbind/base/psb_c_base.h | 2 +- cbind/base/psb_c_cbase.h | 1 + cbind/base/psb_c_dbase.h | 1 + cbind/base/psb_c_sbase.h | 1 + cbind/base/psb_c_tools_cbind_mod.F90 | 197 ++++++++++++-------- cbind/base/psb_c_zbase.h | 1 + cbind/base/psb_d_tools_cbind_mod.F90 | 197 ++++++++++++-------- cbind/base/psb_s_tools_cbind_mod.F90 | 197 ++++++++++++-------- cbind/base/psb_z_tools_cbind_mod.F90 | 197 ++++++++++++-------- 32 files changed, 1149 insertions(+), 428 deletions(-) create mode 100644 base/tools/psb_cgetelem.f90 create mode 100644 base/tools/psb_dgetelem.f90 create mode 100644 base/tools/psb_sgetelem.f90 create mode 100644 base/tools/psb_zgetelem.f90 diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index 250c9ae5..f59e238f 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -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 ! diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index b4dc43ba..144c28ea 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -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 @@ -186,10 +188,10 @@ contains end function psb_c_get_vect_default - subroutine psb_c_clear_vect_default() - implicit none + subroutine psb_c_clear_vect_default() + implicit none - if (allocated(psb_c_base_vect_default)) then + if (allocated(psb_c_base_vect_default)) then deallocate(psb_c_base_vect_default) end if @@ -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 diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 6e5eda62..daf12cbf 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -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 ! diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 0ce96499..daff8c75 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -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 @@ -193,10 +195,10 @@ contains end function psb_d_get_vect_default - subroutine psb_d_clear_vect_default() - implicit none + subroutine psb_d_clear_vect_default() + implicit none - if (allocated(psb_d_base_vect_default)) then + if (allocated(psb_d_base_vect_default)) then deallocate(psb_d_base_vect_default) end if @@ -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 diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index a59f63e6..55d7b47e 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -793,7 +793,6 @@ contains - ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 6fe13325..75064b81 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -135,10 +135,10 @@ contains end function psb_i_get_vect_default - subroutine psb_i_clear_vect_default() - implicit none + subroutine psb_i_clear_vect_default() + implicit none - if (allocated(psb_i_base_vect_default)) then + if (allocated(psb_i_base_vect_default)) then deallocate(psb_i_base_vect_default) end if diff --git a/base/modules/serial/psb_l_base_vect_mod.f90 b/base/modules/serial/psb_l_base_vect_mod.f90 index 30440628..53b45f2a 100644 --- a/base/modules/serial/psb_l_base_vect_mod.f90 +++ b/base/modules/serial/psb_l_base_vect_mod.f90 @@ -794,7 +794,6 @@ contains - ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index c8fe90e6..3c86f8a2 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -136,10 +136,10 @@ contains end function psb_l_get_vect_default - subroutine psb_l_clear_vect_default() - implicit none + subroutine psb_l_clear_vect_default() + implicit none - if (allocated(psb_l_base_vect_default)) then + if (allocated(psb_l_base_vect_default)) then deallocate(psb_l_base_vect_default) end if diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 81367c8f..c185e341 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -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 ! diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 1b9d212d..4c6e3e1c 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -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 @@ -193,10 +195,10 @@ contains end function psb_s_get_vect_default - subroutine psb_s_clear_vect_default() - implicit none + subroutine psb_s_clear_vect_default() + implicit none - if (allocated(psb_s_base_vect_default)) then + if (allocated(psb_s_base_vect_default)) then deallocate(psb_s_base_vect_default) end if @@ -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 diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index 3455b743..1daed233 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -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 ! diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 8ab68a53..52523b61 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -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 @@ -186,10 +188,10 @@ contains end function psb_z_get_vect_default - subroutine psb_z_clear_vect_default() - implicit none + subroutine psb_z_clear_vect_default() + implicit none - if (allocated(psb_z_base_vect_default)) then + if (allocated(psb_z_base_vect_default)) then deallocate(psb_z_base_vect_default) end if @@ -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 diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index fdcc5e56..81e78d3a 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 @@ -27,8 +27,8 @@ ! 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_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 @@ -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) @@ -195,7 +196,7 @@ Module psb_c_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_csphalo Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_c_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_lcsphalo Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_c_tools_mod 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 Subroutine psb_c_lc_csr_halo end interface @@ -296,7 +297,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) +#if defined(IPK4) && defined(LPK8) subroutine psb_cspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_c_tools_mod 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_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 @@ -364,7 +365,7 @@ Module psb_c_tools_mod Implicit None type(psb_lc_csr_sparse_mat),intent(in) :: acsr type(psb_lc_csr_sparse_mat),intent(inout) :: bcsr - type(psb_lc_csr_sparse_mat),intent(out) :: ccsr + type(psb_lc_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 @@ -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 diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index aa127872..76a5bdf2 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 @@ -27,8 +27,8 @@ ! 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_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 @@ -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) @@ -195,7 +196,7 @@ Module psb_d_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_dsphalo Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_d_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_ldsphalo Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_d_tools_mod 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 Subroutine psb_d_ld_csr_halo end interface @@ -296,7 +297,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) +#if defined(IPK4) && defined(LPK8) subroutine psb_dspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_d_tools_mod 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_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 @@ -364,7 +365,7 @@ Module psb_d_tools_mod Implicit None type(psb_ld_csr_sparse_mat),intent(in) :: acsr type(psb_ld_csr_sparse_mat),intent(inout) :: bcsr - type(psb_ld_csr_sparse_mat),intent(out) :: ccsr + type(psb_ld_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 @@ -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 diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index 1faffd66..def96326 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 @@ -27,13 +27,14 @@ ! 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_i_tools_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_ use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type use psb_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) @@ -169,5 +170,5 @@ Module psb_i_tools_mod end subroutine psb_iins_multivect end interface - + end module psb_i_tools_mod diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index 96f44fd7..b389ef85 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 @@ -27,13 +27,14 @@ ! 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_l_tools_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_ use psb_l_vect_mod, only : psb_l_base_vect_type, psb_l_vect_type ! use psb_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) @@ -169,5 +170,5 @@ Module psb_l_tools_mod end subroutine psb_lins_multivect end interface - + end module psb_l_tools_mod diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index 24453728..2b6058da 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 @@ -27,8 +27,8 @@ ! 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_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 @@ -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) @@ -195,7 +196,7 @@ Module psb_s_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_ssphalo Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_s_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_lssphalo Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_s_tools_mod 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 Subroutine psb_s_ls_csr_halo end interface @@ -296,7 +297,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) +#if defined(IPK4) && defined(LPK8) subroutine psb_sspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_s_tools_mod 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_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 @@ -364,7 +365,7 @@ Module psb_s_tools_mod Implicit None type(psb_ls_csr_sparse_mat),intent(in) :: acsr type(psb_ls_csr_sparse_mat),intent(inout) :: bcsr - type(psb_ls_csr_sparse_mat),intent(out) :: ccsr + type(psb_ls_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 @@ -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 diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 2b639fdc..09997e94 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! 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: @@ -15,7 +15,7 @@ ! 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 @@ -27,8 +27,8 @@ ! 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_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 @@ -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) @@ -195,7 +196,7 @@ Module psb_z_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_zsphalo Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_z_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_lzsphalo Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_z_tools_mod 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 Subroutine psb_z_lz_csr_halo end interface @@ -296,7 +297,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) +#if defined(IPK4) && defined(LPK8) subroutine psb_zspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_z_tools_mod 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_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 @@ -364,7 +365,7 @@ Module psb_z_tools_mod Implicit None type(psb_lz_csr_sparse_mat),intent(in) :: acsr type(psb_lz_csr_sparse_mat),intent(inout) :: bcsr - type(psb_lz_csr_sparse_mat),intent(out) :: ccsr + type(psb_lz_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 @@ -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 diff --git a/base/tools/Makefile b/base/tools/Makefile index 6b103d41..c8b488d3 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -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 \ @@ -37,12 +38,12 @@ INCDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(FIFLAG)$(MODDIR) -lib: mpfobjs $(FOBJS) +lib: mpfobjs $(FOBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(FOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) -mpfobjs: +mpfobjs: (make $(MPFOBJS) FC="$(MPFC)") clean: diff --git a/base/tools/psb_cgetelem.f90 b/base/tools/psb_cgetelem.f90 new file mode 100644 index 00000000..a13510cc --- /dev/null +++ b/base/tools/psb_cgetelem.f90 @@ -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: ",myidx + 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 + diff --git a/base/tools/psb_dgetelem.f90 b/base/tools/psb_dgetelem.f90 new file mode 100644 index 00000000..d18c79eb --- /dev/null +++ b/base/tools/psb_dgetelem.f90 @@ -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: ",myidx + 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 + diff --git a/base/tools/psb_sgetelem.f90 b/base/tools/psb_sgetelem.f90 new file mode 100644 index 00000000..1cd8297b --- /dev/null +++ b/base/tools/psb_sgetelem.f90 @@ -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: ",myidx + 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 + diff --git a/base/tools/psb_zgetelem.f90 b/base/tools/psb_zgetelem.f90 new file mode 100644 index 00000000..504e343f --- /dev/null +++ b/base/tools/psb_zgetelem.f90 @@ -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: ",myidx + 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 + diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index b00058ec..7ecd6626 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -89,7 +89,7 @@ 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_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); diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index c2cd173c..55c437a4 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -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(); diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index d1bd39af..40d59a58 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -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(); diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index c259767f..73e3aa2d 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -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(); diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 43014ac8..a935b6c2 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_cgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_cgeall function psb_c_cgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_cgeasb - + function psb_c_cgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_cgefree - + function psb_c_cgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_float_complex) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_cgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_float_complex) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_cspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_cspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_cspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_c_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_cspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) complex(c_float_complex) :: val(*) type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_csprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_cspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -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 diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 48250c55..ee74a651 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -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(); diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index 31f87433..40a9d2f6 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_dgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_dgeall function psb_c_dgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_dgeasb - + function psb_c_dgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_dgefree - + function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_double) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_dgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_double) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_dspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_dspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_dspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_d_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_dspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) real(c_double) :: val(*) type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_dsprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_dspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -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 diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index fad6cdc4..bae645be 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_sgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_sgeall function psb_c_sgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_sgeasb - + function psb_c_sgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_sgefree - + function psb_c_sgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_float) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_sgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_float) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_sspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_sspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_sspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_s_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_sspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) real(c_float) :: val(*) type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_ssprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_sspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -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 diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index 99125022..19802f62 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_zgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_zgeall function psb_c_zgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_zgeasb - + function psb_c_zgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_zgefree - + function psb_c_zgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_double_complex) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_zgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_double_complex) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_zspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_zspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_zspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_z_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_zspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) complex(c_double_complex) :: val(*) type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_zsprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_zspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -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