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

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

Browse Source
This commit is contained in:
Salvatore Filippone
2020-10-11 18:45:28 +02:00
parent 7b133657d4 c0c8224253
commit b7926336ac
32 changed files with 1148 additions and 428 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/serial/psb_c_base_vect_mod.f90
+21
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
!
base/modules/serial/psb_c_vect_mod.F90
+14 -3
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
@@ -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
base/modules/serial/psb_d_base_vect_mod.f90
+21
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
!
base/modules/serial/psb_d_vect_mod.F90
+14 -3
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
@@ -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
base/modules/serial/psb_i_base_vect_mod.f90
-1
View File
@@ -793,7 +793,6 @@ contains
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
base/modules/serial/psb_i_vect_mod.F90
+3 -3
View File
@@ -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
base/modules/serial/psb_l_base_vect_mod.f90
-1
View File
@@ -794,7 +794,6 @@ contains
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
base/modules/serial/psb_l_vect_mod.F90
+3 -3
View File
@@ -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
base/modules/serial/psb_s_base_vect_mod.f90
+21
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
!
base/modules/serial/psb_s_vect_mod.F90
+14 -3
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
@@ -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
base/modules/serial/psb_z_base_vect_mod.f90
+21
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
!
base/modules/serial/psb_z_vect_mod.F90
+14 -3
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
@@ -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
base/modules/tools/psb_c_tools_mod.F90
+26 -15
View File
@@ -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
base/modules/tools/psb_d_tools_mod.F90
+26 -15
View File
@@ -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
base/modules/tools/psb_i_tools_mod.F90
+9 -8
View File
@@ -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
base/modules/tools/psb_l_tools_mod.F90
+9 -8
View File
@@ -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
base/modules/tools/psb_s_tools_mod.F90
+26 -15
View File
@@ -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
base/modules/tools/psb_z_tools_mod.F90
+26 -15
View File
@@ -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
base/tools/Makefile
+4 -3
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 \
@@ -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:
base/tools/psb_cgetelem.f90
+103
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
base/tools/psb_dgetelem.f90
+103
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
base/tools/psb_sgetelem.f90
+103
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
base/tools/psb_zgetelem.f90
+103
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
cbind/base/psb_c_base.h
-1
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 */
cbind/base/psb_c_cbase.h
+1
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();
cbind/base/psb_c_dbase.h
+1
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();
cbind/base/psb_c_sbase.h
+1
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();
cbind/base/psb_c_tools_cbind_mod.F90
+115 -82
View File
@@ -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
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
cbind/base/psb_c_zbase.h
+1
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();
cbind/base/psb_d_tools_cbind_mod.F90
+115 -82
View File
@@ -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
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
cbind/base/psb_s_tools_cbind_mod.F90
+115 -82
View File
@@ -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
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
cbind/base/psb_z_tools_cbind_mod.F90
+115 -82
View File
@@ -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
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