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

psblas3:

Browse Source 
base/modules/psb_c_base_mat_mod.f90
 base/modules/psb_c_mat_mod.f90
 base/modules/psb_c_vect_mod.F90
 base/modules/psb_d_base_mat_mod.f90
 base/modules/psb_d_mat_mod.f90
 base/modules/psb_d_vect_mod.F90
 base/modules/psb_i_vect_mod.F90
 base/modules/psb_s_base_mat_mod.f90
 base/modules/psb_s_mat_mod.f90
 base/modules/psb_s_vect_mod.F90
 base/modules/psb_z_base_mat_mod.f90
 base/modules/psb_z_mat_mod.f90
 base/modules/psb_z_vect_mod.F90
 base/serial/impl/psb_c_base_mat_impl.F90
 base/serial/impl/psb_c_coo_impl.f90
 base/serial/impl/psb_c_csc_impl.f90
 base/serial/impl/psb_c_csr_impl.f90
 base/serial/impl/psb_d_base_mat_impl.F90
 base/serial/impl/psb_d_coo_impl.f90
 base/serial/impl/psb_d_csc_impl.f90
 base/serial/impl/psb_d_csr_impl.f90
 base/serial/impl/psb_s_base_mat_impl.F90
 base/serial/impl/psb_s_coo_impl.f90
 base/serial/impl/psb_s_csc_impl.f90
 base/serial/impl/psb_s_csr_impl.f90
 base/serial/impl/psb_z_base_mat_impl.F90
 base/serial/impl/psb_z_coo_impl.f90
 base/serial/impl/psb_z_csc_impl.f90
 base/serial/impl/psb_z_csr_impl.f90
 base/tools/psb_cspins.f90
 base/tools/psb_dspins.f90
 base/tools/psb_sspins.f90
 base/tools/psb_zspins.f90
 util/Makefile
 util/psb_i_mmio_impl.f90
 util/psb_mmio_mod.F90

Cosmetic fixes to vectors.
Add SYNC methods to matrices (they are no-op here, but make for safety).
psblas-3.4-maint
Salvatore Filippone 10 years ago
parent 3480d27fdf
commit cfaa5489c7
36 changed files with 2047 additions and 365 deletions
Show Stats Download Patch File Download Diff File

4
base/modules/psb_c_base_mat_mod.f90
Unescape Escape View File

@ -114,6 +114,10 @@ module psb_c_base_mat_mod
procedure, pass(a) :: aclsum => psb_c_base_aclsum
end type psb_c_base_sparse_mat
private :: c_base_mat_sync, c_base_mat_is_host, c_base_mat_is_dev, &
& c_base_mat_is_sync, c_base_mat_set_host, c_base_mat_set_dev,&
& c_base_mat_set_sync
!> \namespace psb_base_mod \class psb_c_coo_sparse_mat
!! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat
!!

110
base/modules/psb_c_mat_mod.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! the functionalities to have the encapsulated class change its
! type dynamically, and to extract/input an inner object.
!
! A sparse matric has a state corresponding to its progression
! A sparse matrix has a state corresponding to its progression
! through the application life.
! In particular, computational methods can only be invoked when
! the matrix is in the ASSEMBLED state, whereas the other states are
@ -147,6 +147,23 @@ module psb_c_mat_mod
procedure, pass(a) :: transc_1mat => psb_c_transc_1mat
procedure, pass(a) :: transc_2mat => psb_c_transc_2mat
generic, public :: transc => transc_1mat, transc_2mat
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
! will guarantee that both fortran/host side and
! external side contain the same data. The base
! version is only a placeholder.
!
procedure, pass(a) :: sync => c_mat_sync
procedure, pass(a) :: is_host => c_mat_is_host
procedure, pass(a) :: is_dev => c_mat_is_dev
procedure, pass(a) :: is_sync => c_mat_is_sync
procedure, pass(a) :: set_host => c_mat_set_host
procedure, pass(a) :: set_dev => c_mat_set_dev
procedure, pass(a) :: set_sync => c_mat_set_sync
! These are specific to this level of encapsulation.
procedure, pass(a) :: mv_from_b => psb_c_mv_from
generic, public :: mv_from => mv_from_b
@ -188,11 +205,17 @@ module psb_c_mat_mod
end type psb_cspmat_type
private :: psb_c_get_nrows, psb_c_get_ncols, psb_c_get_nzeros, psb_c_get_size, &
private :: psb_c_get_nrows, psb_c_get_ncols, &
& psb_c_get_nzeros, psb_c_get_size, &
& psb_c_get_dupl, psb_c_is_null, psb_c_is_bld, &
& psb_c_is_upd, psb_c_is_asb, psb_c_is_sorted, &
& psb_c_is_by_rows, psb_c_is_by_cols, psb_c_is_upper, &
& psb_c_is_lower, psb_c_is_triangle, psb_c_get_nz_row
& psb_c_is_lower, psb_c_is_triangle, psb_c_get_nz_row, &
& c_mat_sync, c_mat_is_host, c_mat_is_dev, &
& c_mat_is_sync, c_mat_set_host, c_mat_set_dev,&
& c_mat_set_sync
class(psb_c_base_sparse_mat), allocatable, target, &
& save, private :: psb_c_base_mat_default
@ -1112,6 +1135,85 @@ contains
end function psb_c_is_by_cols
!
subroutine c_mat_sync(a)
implicit none
class(psb_cspmat_type), target, intent(in) :: a
if (allocated(a%a)) call a%a%sync()
end subroutine c_mat_sync
!
subroutine c_mat_set_host(a)
implicit none
class(psb_cspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_host()
end subroutine c_mat_set_host
!
subroutine c_mat_set_dev(a)
implicit none
class(psb_cspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_dev()
end subroutine c_mat_set_dev
!
subroutine c_mat_set_sync(a)
implicit none
class(psb_cspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_sync()
end subroutine c_mat_set_sync
!
function c_mat_is_dev(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_dev()
else
res = .false.
end if
end function c_mat_is_dev
!
function c_mat_is_host(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_host()
else
res = .true.
end if
end function c_mat_is_host
!
function c_mat_is_sync(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_sync()
else
res = .true.
end if
end function c_mat_is_sync
function psb_c_is_repeatable_updates(a) result(res)
implicit none
@ -1178,4 +1280,6 @@ contains
end function psb_c_get_nz_row
end module psb_c_mat_mod

106
base/modules/psb_c_vect_mod.F90
Unescape Escape View File

@ -52,7 +52,6 @@ module psb_c_vect_mod
procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero
procedure, pass(x) :: asb => c_vect_asb
procedure, pass(x) :: sync => c_vect_sync
procedure, pass(x) :: gthab => c_vect_gthab
procedure, pass(x) :: gthzv => c_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -71,6 +70,15 @@ module psb_c_vect_mod
procedure, pass(x) :: set_vect => c_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => c_vect_clone
procedure, pass(x) :: sync => c_vect_sync
procedure, pass(x) :: is_host => c_vect_is_host
procedure, pass(x) :: is_dev => c_vect_is_dev
procedure, pass(x) :: is_sync => c_vect_is_sync
procedure, pass(x) :: set_host => c_vect_set_host
procedure, pass(x) :: set_dev => c_vect_set_dev
procedure, pass(x) :: set_sync => c_vect_set_sync
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
@ -100,6 +108,22 @@ module psb_c_vect_mod
module procedure constructor, size_const
end interface psb_c_vect
private :: c_vect_get_nrows, c_vect_sizeof, c_vect_get_fmt, &
& c_vect_all, c_vect_reall, c_vect_zero, c_vect_asb, &
& c_vect_gthab, c_vect_gthzv, c_vect_sctb, &
& c_vect_free, c_vect_ins_a, c_vect_ins_v, c_vect_bld_x, &
& c_vect_bld_n, c_vect_get_vect, c_vect_cnv, c_vect_set_scal, &
& c_vect_set_vect, c_vect_clone, c_vect_sync, c_vect_is_host, &
& c_vect_is_dev, c_vect_is_sync, c_vect_set_host, &
& c_vect_set_dev, c_vect_set_sync
private :: c_vect_dot_v, c_vect_dot_a, c_vect_axpby_v, c_vect_axpby_a, &
& c_vect_mlt_v, c_vect_mlt_a, c_vect_mlt_a_2, c_vect_mlt_v_2, &
& c_vect_mlt_va, c_vect_mlt_av, c_vect_scal, c_vect_absval1, &
& c_vect_absval2, c_vect_nrm2, c_vect_amax, c_vect_asum
class(psb_c_base_vect_type), allocatable, target,&
& save, private :: psb_c_base_vect_default
@ -361,15 +385,6 @@ contains
end subroutine c_vect_asb
subroutine c_vect_sync(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine c_vect_sync
subroutine c_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
@ -482,6 +497,77 @@ contains
end if
end subroutine c_vect_cnv
subroutine c_vect_sync(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine c_vect_sync
subroutine c_vect_set_sync(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_sync()
end subroutine c_vect_set_sync
subroutine c_vect_set_host(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_host()
end subroutine c_vect_set_host
subroutine c_vect_set_dev(x)
implicit none
class(psb_c_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_dev()
end subroutine c_vect_set_dev
function c_vect_is_sync(x) result(res)
implicit none
logical :: res
class(psb_c_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_sync()
end function c_vect_is_sync
function c_vect_is_host(x) result(res)
implicit none
logical :: res
class(psb_c_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_host()
end function c_vect_is_host
function c_vect_is_dev(x) result(res)
implicit none
logical :: res
class(psb_c_vect_type), intent(inout) :: x
res = .false.
if (allocated(x%v)) &
& res = x%v%is_dev()
end function c_vect_is_dev
function c_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_c_vect_type), intent(inout) :: x, y

4
base/modules/psb_d_base_mat_mod.f90
Unescape Escape View File

@ -114,6 +114,10 @@ module psb_d_base_mat_mod
procedure, pass(a) :: aclsum => psb_d_base_aclsum
end type psb_d_base_sparse_mat
private :: d_base_mat_sync, d_base_mat_is_host, d_base_mat_is_dev, &
& d_base_mat_is_sync, d_base_mat_set_host, d_base_mat_set_dev,&
& d_base_mat_set_sync
!> \namespace psb_base_mod \class psb_d_coo_sparse_mat
!! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat
!!

110
base/modules/psb_d_mat_mod.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! the functionalities to have the encapsulated class change its
! type dynamically, and to extract/input an inner object.
!
! A sparse matric has a state corresponding to its progression
! A sparse matrix has a state corresponding to its progression
! through the application life.
! In particular, computational methods can only be invoked when
! the matrix is in the ASSEMBLED state, whereas the other states are
@ -147,6 +147,23 @@ module psb_d_mat_mod
procedure, pass(a) :: transc_1mat => psb_d_transc_1mat
procedure, pass(a) :: transc_2mat => psb_d_transc_2mat
generic, public :: transc => transc_1mat, transc_2mat
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
! will guarantee that both fortran/host side and
! external side contain the same data. The base
! version is only a placeholder.
!
procedure, pass(a) :: sync => d_mat_sync
procedure, pass(a) :: is_host => d_mat_is_host
procedure, pass(a) :: is_dev => d_mat_is_dev
procedure, pass(a) :: is_sync => d_mat_is_sync
procedure, pass(a) :: set_host => d_mat_set_host
procedure, pass(a) :: set_dev => d_mat_set_dev
procedure, pass(a) :: set_sync => d_mat_set_sync
! These are specific to this level of encapsulation.
procedure, pass(a) :: mv_from_b => psb_d_mv_from
generic, public :: mv_from => mv_from_b
@ -188,11 +205,17 @@ module psb_d_mat_mod
end type psb_dspmat_type
private :: psb_d_get_nrows, psb_d_get_ncols, psb_d_get_nzeros, psb_d_get_size, &
private :: psb_d_get_nrows, psb_d_get_ncols, &
& psb_d_get_nzeros, psb_d_get_size, &
& psb_d_get_dupl, psb_d_is_null, psb_d_is_bld, &
& psb_d_is_upd, psb_d_is_asb, psb_d_is_sorted, &
& psb_d_is_by_rows, psb_d_is_by_cols, psb_d_is_upper, &
& psb_d_is_lower, psb_d_is_triangle, psb_d_get_nz_row
& psb_d_is_lower, psb_d_is_triangle, psb_d_get_nz_row, &
& d_mat_sync, d_mat_is_host, d_mat_is_dev, &
& d_mat_is_sync, d_mat_set_host, d_mat_set_dev,&
& d_mat_set_sync
class(psb_d_base_sparse_mat), allocatable, target, &
& save, private :: psb_d_base_mat_default
@ -1112,6 +1135,85 @@ contains
end function psb_d_is_by_cols
!
subroutine d_mat_sync(a)
implicit none
class(psb_dspmat_type), target, intent(in) :: a
if (allocated(a%a)) call a%a%sync()
end subroutine d_mat_sync
!
subroutine d_mat_set_host(a)
implicit none
class(psb_dspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_host()
end subroutine d_mat_set_host
!
subroutine d_mat_set_dev(a)
implicit none
class(psb_dspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_dev()
end subroutine d_mat_set_dev
!
subroutine d_mat_set_sync(a)
implicit none
class(psb_dspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_sync()
end subroutine d_mat_set_sync
!
function d_mat_is_dev(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_dev()
else
res = .false.
end if
end function d_mat_is_dev
!
function d_mat_is_host(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_host()
else
res = .true.
end if
end function d_mat_is_host
!
function d_mat_is_sync(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_sync()
else
res = .true.
end if
end function d_mat_is_sync
function psb_d_is_repeatable_updates(a) result(res)
implicit none
@ -1178,4 +1280,6 @@ contains
end function psb_d_get_nz_row
end module psb_d_mat_mod

106
base/modules/psb_d_vect_mod.F90
Unescape Escape View File

@ -52,7 +52,6 @@ module psb_d_vect_mod
procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero
procedure, pass(x) :: asb => d_vect_asb
procedure, pass(x) :: sync => d_vect_sync
procedure, pass(x) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -71,6 +70,15 @@ module psb_d_vect_mod
procedure, pass(x) :: set_vect => d_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => d_vect_clone
procedure, pass(x) :: sync => d_vect_sync
procedure, pass(x) :: is_host => d_vect_is_host
procedure, pass(x) :: is_dev => d_vect_is_dev
procedure, pass(x) :: is_sync => d_vect_is_sync
procedure, pass(x) :: set_host => d_vect_set_host
procedure, pass(x) :: set_dev => d_vect_set_dev
procedure, pass(x) :: set_sync => d_vect_set_sync
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
@ -100,6 +108,22 @@ module psb_d_vect_mod
module procedure constructor, size_const
end interface psb_d_vect
private :: d_vect_get_nrows, d_vect_sizeof, d_vect_get_fmt, &
& d_vect_all, d_vect_reall, d_vect_zero, d_vect_asb, &
& d_vect_gthab, d_vect_gthzv, d_vect_sctb, &
& d_vect_free, d_vect_ins_a, d_vect_ins_v, d_vect_bld_x, &
& d_vect_bld_n, d_vect_get_vect, d_vect_cnv, d_vect_set_scal, &
& d_vect_set_vect, d_vect_clone, d_vect_sync, d_vect_is_host, &
& d_vect_is_dev, d_vect_is_sync, d_vect_set_host, &
& d_vect_set_dev, d_vect_set_sync
private :: d_vect_dot_v, d_vect_dot_a, d_vect_axpby_v, d_vect_axpby_a, &
& d_vect_mlt_v, d_vect_mlt_a, d_vect_mlt_a_2, d_vect_mlt_v_2, &
& d_vect_mlt_va, d_vect_mlt_av, d_vect_scal, d_vect_absval1, &
& d_vect_absval2, d_vect_nrm2, d_vect_amax, d_vect_asum
class(psb_d_base_vect_type), allocatable, target,&
& save, private :: psb_d_base_vect_default
@ -361,15 +385,6 @@ contains
end subroutine d_vect_asb
subroutine d_vect_sync(x)
implicit none
class(psb_d_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine d_vect_sync
subroutine d_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
@ -482,6 +497,77 @@ contains
end if
end subroutine d_vect_cnv
subroutine d_vect_sync(x)
implicit none
class(psb_d_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine d_vect_sync
subroutine d_vect_set_sync(x)
implicit none
class(psb_d_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_sync()
end subroutine d_vect_set_sync
subroutine d_vect_set_host(x)
implicit none
class(psb_d_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_host()
end subroutine d_vect_set_host
subroutine d_vect_set_dev(x)
implicit none
class(psb_d_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_dev()
end subroutine d_vect_set_dev
function d_vect_is_sync(x) result(res)
implicit none
logical :: res
class(psb_d_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_sync()
end function d_vect_is_sync
function d_vect_is_host(x) result(res)
implicit none
logical :: res
class(psb_d_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_host()
end function d_vect_is_host
function d_vect_is_dev(x) result(res)
implicit none
logical :: res
class(psb_d_vect_type), intent(inout) :: x
res = .false.
if (allocated(x%v)) &
& res = x%v%is_dev()
end function d_vect_is_dev
function d_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_d_vect_type), intent(inout) :: x, y

101
base/modules/psb_i_vect_mod.F90
Unescape Escape View File

@ -51,7 +51,6 @@ module psb_i_vect_mod
procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb
procedure, pass(x) :: sync => i_vect_sync
procedure, pass(x) :: gthab => i_vect_gthab
procedure, pass(x) :: gthzv => i_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -70,6 +69,15 @@ module psb_i_vect_mod
procedure, pass(x) :: set_vect => i_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => i_vect_clone
procedure, pass(x) :: sync => i_vect_sync
procedure, pass(x) :: is_host => i_vect_is_host
procedure, pass(x) :: is_dev => i_vect_is_dev
procedure, pass(x) :: is_sync => i_vect_is_sync
procedure, pass(x) :: set_host => i_vect_set_host
procedure, pass(x) :: set_dev => i_vect_set_dev
procedure, pass(x) :: set_sync => i_vect_set_sync
end type psb_i_vect_type
public :: psb_i_vect
@ -78,6 +86,17 @@ module psb_i_vect_mod
module procedure constructor, size_const
end interface psb_i_vect
private :: i_vect_get_nrows, i_vect_sizeof, i_vect_get_fmt, &
& i_vect_all, i_vect_reall, i_vect_zero, i_vect_asb, &
& i_vect_gthab, i_vect_gthzv, i_vect_sctb, &
& i_vect_free, i_vect_ins_a, i_vect_ins_v, i_vect_bld_x, &
& i_vect_bld_n, i_vect_get_vect, i_vect_cnv, i_vect_set_scal, &
& i_vect_set_vect, i_vect_clone, i_vect_sync, i_vect_is_host, &
& i_vect_is_dev, i_vect_is_sync, i_vect_set_host, &
& i_vect_set_dev, i_vect_set_sync
class(psb_i_base_vect_type), allocatable, target,&
& save, private :: psb_i_base_vect_default
@ -339,15 +358,6 @@ contains
end subroutine i_vect_asb
subroutine i_vect_sync(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine i_vect_sync
subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
@ -460,6 +470,77 @@ contains
end if
end subroutine i_vect_cnv
subroutine i_vect_sync(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine i_vect_sync
subroutine i_vect_set_sync(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_sync()
end subroutine i_vect_set_sync
subroutine i_vect_set_host(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_host()
end subroutine i_vect_set_host
subroutine i_vect_set_dev(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_dev()
end subroutine i_vect_set_dev
function i_vect_is_sync(x) result(res)
implicit none
logical :: res
class(psb_i_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_sync()
end function i_vect_is_sync
function i_vect_is_host(x) result(res)
implicit none
logical :: res
class(psb_i_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_host()
end function i_vect_is_host
function i_vect_is_dev(x) result(res)
implicit none
logical :: res
class(psb_i_vect_type), intent(inout) :: x
res = .false.
if (allocated(x%v)) &
& res = x%v%is_dev()
end function i_vect_is_dev
end module psb_i_vect_mod

4
base/modules/psb_s_base_mat_mod.f90
Unescape Escape View File

@ -114,6 +114,10 @@ module psb_s_base_mat_mod
procedure, pass(a) :: aclsum => psb_s_base_aclsum
end type psb_s_base_sparse_mat
private :: s_base_mat_sync, s_base_mat_is_host, s_base_mat_is_dev, &
& s_base_mat_is_sync, s_base_mat_set_host, s_base_mat_set_dev,&
& s_base_mat_set_sync
!> \namespace psb_base_mod \class psb_s_coo_sparse_mat
!! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat
!!

110
base/modules/psb_s_mat_mod.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! the functionalities to have the encapsulated class change its
! type dynamically, and to extract/input an inner object.
!
! A sparse matric has a state corresponding to its progression
! A sparse matrix has a state corresponding to its progression
! through the application life.
! In particular, computational methods can only be invoked when
! the matrix is in the ASSEMBLED state, whereas the other states are
@ -147,6 +147,23 @@ module psb_s_mat_mod
procedure, pass(a) :: transc_1mat => psb_s_transc_1mat
procedure, pass(a) :: transc_2mat => psb_s_transc_2mat
generic, public :: transc => transc_1mat, transc_2mat
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
! will guarantee that both fortran/host side and
! external side contain the same data. The base
! version is only a placeholder.
!
procedure, pass(a) :: sync => s_mat_sync
procedure, pass(a) :: is_host => s_mat_is_host
procedure, pass(a) :: is_dev => s_mat_is_dev
procedure, pass(a) :: is_sync => s_mat_is_sync
procedure, pass(a) :: set_host => s_mat_set_host
procedure, pass(a) :: set_dev => s_mat_set_dev
procedure, pass(a) :: set_sync => s_mat_set_sync
! These are specific to this level of encapsulation.
procedure, pass(a) :: mv_from_b => psb_s_mv_from
generic, public :: mv_from => mv_from_b
@ -188,11 +205,17 @@ module psb_s_mat_mod
end type psb_sspmat_type
private :: psb_s_get_nrows, psb_s_get_ncols, psb_s_get_nzeros, psb_s_get_size, &
private :: psb_s_get_nrows, psb_s_get_ncols, &
& psb_s_get_nzeros, psb_s_get_size, &
& psb_s_get_dupl, psb_s_is_null, psb_s_is_bld, &
& psb_s_is_upd, psb_s_is_asb, psb_s_is_sorted, &
& psb_s_is_by_rows, psb_s_is_by_cols, psb_s_is_upper, &
& psb_s_is_lower, psb_s_is_triangle, psb_s_get_nz_row
& psb_s_is_lower, psb_s_is_triangle, psb_s_get_nz_row, &
& s_mat_sync, s_mat_is_host, s_mat_is_dev, &
& s_mat_is_sync, s_mat_set_host, s_mat_set_dev,&
& s_mat_set_sync
class(psb_s_base_sparse_mat), allocatable, target, &
& save, private :: psb_s_base_mat_default
@ -1112,6 +1135,85 @@ contains
end function psb_s_is_by_cols
!
subroutine s_mat_sync(a)
implicit none
class(psb_sspmat_type), target, intent(in) :: a
if (allocated(a%a)) call a%a%sync()
end subroutine s_mat_sync
!
subroutine s_mat_set_host(a)
implicit none
class(psb_sspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_host()
end subroutine s_mat_set_host
!
subroutine s_mat_set_dev(a)
implicit none
class(psb_sspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_dev()
end subroutine s_mat_set_dev
!
subroutine s_mat_set_sync(a)
implicit none
class(psb_sspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_sync()
end subroutine s_mat_set_sync
!
function s_mat_is_dev(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_dev()
else
res = .false.
end if
end function s_mat_is_dev
!
function s_mat_is_host(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_host()
else
res = .true.
end if
end function s_mat_is_host
!
function s_mat_is_sync(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_sync()
else
res = .true.
end if
end function s_mat_is_sync
function psb_s_is_repeatable_updates(a) result(res)
implicit none
@ -1178,4 +1280,6 @@ contains
end function psb_s_get_nz_row
end module psb_s_mat_mod

106
base/modules/psb_s_vect_mod.F90
Unescape Escape View File

@ -52,7 +52,6 @@ module psb_s_vect_mod
procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero
procedure, pass(x) :: asb => s_vect_asb
procedure, pass(x) :: sync => s_vect_sync
procedure, pass(x) :: gthab => s_vect_gthab
procedure, pass(x) :: gthzv => s_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -71,6 +70,15 @@ module psb_s_vect_mod
procedure, pass(x) :: set_vect => s_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => s_vect_clone
procedure, pass(x) :: sync => s_vect_sync
procedure, pass(x) :: is_host => s_vect_is_host
procedure, pass(x) :: is_dev => s_vect_is_dev
procedure, pass(x) :: is_sync => s_vect_is_sync
procedure, pass(x) :: set_host => s_vect_set_host
procedure, pass(x) :: set_dev => s_vect_set_dev
procedure, pass(x) :: set_sync => s_vect_set_sync
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
@ -100,6 +108,22 @@ module psb_s_vect_mod
module procedure constructor, size_const
end interface psb_s_vect
private :: s_vect_get_nrows, s_vect_sizeof, s_vect_get_fmt, &
& s_vect_all, s_vect_reall, s_vect_zero, s_vect_asb, &
& s_vect_gthab, s_vect_gthzv, s_vect_sctb, &
& s_vect_free, s_vect_ins_a, s_vect_ins_v, s_vect_bld_x, &
& s_vect_bld_n, s_vect_get_vect, s_vect_cnv, s_vect_set_scal, &
& s_vect_set_vect, s_vect_clone, s_vect_sync, s_vect_is_host, &
& s_vect_is_dev, s_vect_is_sync, s_vect_set_host, &
& s_vect_set_dev, s_vect_set_sync
private :: s_vect_dot_v, s_vect_dot_a, s_vect_axpby_v, s_vect_axpby_a, &
& s_vect_mlt_v, s_vect_mlt_a, s_vect_mlt_a_2, s_vect_mlt_v_2, &
& s_vect_mlt_va, s_vect_mlt_av, s_vect_scal, s_vect_absval1, &
& s_vect_absval2, s_vect_nrm2, s_vect_amax, s_vect_asum
class(psb_s_base_vect_type), allocatable, target,&
& save, private :: psb_s_base_vect_default
@ -361,15 +385,6 @@ contains
end subroutine s_vect_asb
subroutine s_vect_sync(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine s_vect_sync
subroutine s_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
@ -482,6 +497,77 @@ contains
end if
end subroutine s_vect_cnv
subroutine s_vect_sync(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine s_vect_sync
subroutine s_vect_set_sync(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_sync()
end subroutine s_vect_set_sync
subroutine s_vect_set_host(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_host()
end subroutine s_vect_set_host
subroutine s_vect_set_dev(x)
implicit none
class(psb_s_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_dev()
end subroutine s_vect_set_dev
function s_vect_is_sync(x) result(res)
implicit none
logical :: res
class(psb_s_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_sync()
end function s_vect_is_sync
function s_vect_is_host(x) result(res)
implicit none
logical :: res
class(psb_s_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_host()
end function s_vect_is_host
function s_vect_is_dev(x) result(res)
implicit none
logical :: res
class(psb_s_vect_type), intent(inout) :: x
res = .false.
if (allocated(x%v)) &
& res = x%v%is_dev()
end function s_vect_is_dev
function s_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_s_vect_type), intent(inout) :: x, y

4
base/modules/psb_z_base_mat_mod.f90
Unescape Escape View File

@ -114,6 +114,10 @@ module psb_z_base_mat_mod
procedure, pass(a) :: aclsum => psb_z_base_aclsum
end type psb_z_base_sparse_mat
private :: z_base_mat_sync, z_base_mat_is_host, z_base_mat_is_dev, &
& z_base_mat_is_sync, z_base_mat_set_host, z_base_mat_set_dev,&
& z_base_mat_set_sync
!> \namespace psb_base_mod \class psb_z_coo_sparse_mat
!! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat
!!

110
base/modules/psb_z_mat_mod.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! the functionalities to have the encapsulated class change its
! type dynamically, and to extract/input an inner object.
!
! A sparse matric has a state corresponding to its progression
! A sparse matrix has a state corresponding to its progression
! through the application life.
! In particular, computational methods can only be invoked when
! the matrix is in the ASSEMBLED state, whereas the other states are
@ -147,6 +147,23 @@ module psb_z_mat_mod
procedure, pass(a) :: transc_1mat => psb_z_transc_1mat
procedure, pass(a) :: transc_2mat => psb_z_transc_2mat
generic, public :: transc => transc_1mat, transc_2mat
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
! will guarantee that both fortran/host side and
! external side contain the same data. The base
! version is only a placeholder.
!
procedure, pass(a) :: sync => z_mat_sync
procedure, pass(a) :: is_host => z_mat_is_host
procedure, pass(a) :: is_dev => z_mat_is_dev
procedure, pass(a) :: is_sync => z_mat_is_sync
procedure, pass(a) :: set_host => z_mat_set_host
procedure, pass(a) :: set_dev => z_mat_set_dev
procedure, pass(a) :: set_sync => z_mat_set_sync
! These are specific to this level of encapsulation.
procedure, pass(a) :: mv_from_b => psb_z_mv_from
generic, public :: mv_from => mv_from_b
@ -188,11 +205,17 @@ module psb_z_mat_mod
end type psb_zspmat_type
private :: psb_z_get_nrows, psb_z_get_ncols, psb_z_get_nzeros, psb_z_get_size, &
private :: psb_z_get_nrows, psb_z_get_ncols, &
& psb_z_get_nzeros, psb_z_get_size, &
& psb_z_get_dupl, psb_z_is_null, psb_z_is_bld, &
& psb_z_is_upd, psb_z_is_asb, psb_z_is_sorted, &
& psb_z_is_by_rows, psb_z_is_by_cols, psb_z_is_upper, &
& psb_z_is_lower, psb_z_is_triangle, psb_z_get_nz_row
& psb_z_is_lower, psb_z_is_triangle, psb_z_get_nz_row, &
& z_mat_sync, z_mat_is_host, z_mat_is_dev, &
& z_mat_is_sync, z_mat_set_host, z_mat_set_dev,&
& z_mat_set_sync
class(psb_z_base_sparse_mat), allocatable, target, &
& save, private :: psb_z_base_mat_default
@ -1112,6 +1135,85 @@ contains
end function psb_z_is_by_cols
!
subroutine z_mat_sync(a)
implicit none
class(psb_zspmat_type), target, intent(in) :: a
if (allocated(a%a)) call a%a%sync()
end subroutine z_mat_sync
!
subroutine z_mat_set_host(a)
implicit none
class(psb_zspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_host()
end subroutine z_mat_set_host
!
subroutine z_mat_set_dev(a)
implicit none
class(psb_zspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_dev()
end subroutine z_mat_set_dev
!
subroutine z_mat_set_sync(a)
implicit none
class(psb_zspmat_type), intent(inout) :: a
if (allocated(a%a)) call a%a%set_sync()
end subroutine z_mat_set_sync
!
function z_mat_is_dev(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_dev()
else
res = .false.
end if
end function z_mat_is_dev
!
function z_mat_is_host(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_host()
else
res = .true.
end if
end function z_mat_is_host
!
function z_mat_is_sync(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_sync()
else
res = .true.
end if
end function z_mat_is_sync
function psb_z_is_repeatable_updates(a) result(res)
implicit none
@ -1178,4 +1280,6 @@ contains
end function psb_z_get_nz_row
end module psb_z_mat_mod

106
base/modules/psb_z_vect_mod.F90
Unescape Escape View File

@ -52,7 +52,6 @@ module psb_z_vect_mod
procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero
procedure, pass(x) :: asb => z_vect_asb
procedure, pass(x) :: sync => z_vect_sync
procedure, pass(x) :: gthab => z_vect_gthab
procedure, pass(x) :: gthzv => z_vect_gthzv
generic, public :: gth => gthab, gthzv
@ -71,6 +70,15 @@ module psb_z_vect_mod
procedure, pass(x) :: set_vect => z_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => z_vect_clone
procedure, pass(x) :: sync => z_vect_sync
procedure, pass(x) :: is_host => z_vect_is_host
procedure, pass(x) :: is_dev => z_vect_is_dev
procedure, pass(x) :: is_sync => z_vect_is_sync
procedure, pass(x) :: set_host => z_vect_set_host
procedure, pass(x) :: set_dev => z_vect_set_dev
procedure, pass(x) :: set_sync => z_vect_set_sync
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
@ -100,6 +108,22 @@ module psb_z_vect_mod
module procedure constructor, size_const
end interface psb_z_vect
private :: z_vect_get_nrows, z_vect_sizeof, z_vect_get_fmt, &
& z_vect_all, z_vect_reall, z_vect_zero, z_vect_asb, &
& z_vect_gthab, z_vect_gthzv, z_vect_sctb, &
& z_vect_free, z_vect_ins_a, z_vect_ins_v, z_vect_bld_x, &
& z_vect_bld_n, z_vect_get_vect, z_vect_cnv, z_vect_set_scal, &
& z_vect_set_vect, z_vect_clone, z_vect_sync, z_vect_is_host, &
& z_vect_is_dev, z_vect_is_sync, z_vect_set_host, &
& z_vect_set_dev, z_vect_set_sync
private :: z_vect_dot_v, z_vect_dot_a, z_vect_axpby_v, z_vect_axpby_a, &
& z_vect_mlt_v, z_vect_mlt_a, z_vect_mlt_a_2, z_vect_mlt_v_2, &
& z_vect_mlt_va, z_vect_mlt_av, z_vect_scal, z_vect_absval1, &
& z_vect_absval2, z_vect_nrm2, z_vect_amax, z_vect_asum
class(psb_z_base_vect_type), allocatable, target,&
& save, private :: psb_z_base_vect_default
@ -361,15 +385,6 @@ contains
end subroutine z_vect_asb
subroutine z_vect_sync(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine z_vect_sync
subroutine z_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
@ -482,6 +497,77 @@ contains
end if
end subroutine z_vect_cnv
subroutine z_vect_sync(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine z_vect_sync
subroutine z_vect_set_sync(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_sync()
end subroutine z_vect_set_sync
subroutine z_vect_set_host(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_host()
end subroutine z_vect_set_host
subroutine z_vect_set_dev(x)
implicit none
class(psb_z_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%set_dev()
end subroutine z_vect_set_dev
function z_vect_is_sync(x) result(res)
implicit none
logical :: res
class(psb_z_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_sync()
end function z_vect_is_sync
function z_vect_is_host(x) result(res)
implicit none
logical :: res
class(psb_z_vect_type), intent(inout) :: x
res = .true.
if (allocated(x%v)) &
& res = x%v%is_host()
end function z_vect_is_host
function z_vect_is_dev(x) result(res)
implicit none
logical :: res
class(psb_z_vect_type), intent(inout) :: x
res = .false.
if (allocated(x%v)) &
& res = x%v%is_dev()
end function z_vect_is_dev
function z_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_z_vect_type), intent(inout) :: x, y

5
base/serial/impl/psb_c_base_mat_impl.F90
Unescape Escape View File

@ -367,9 +367,10 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (a%is_dev()) call a%sync()
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_

44
base/serial/impl/psb_c_coo_impl.f90
Unescape Escape View File

@ -46,6 +46,7 @@ subroutine psb_c_coo_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -96,6 +97,7 @@ subroutine psb_c_coo_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -135,6 +137,7 @@ subroutine psb_c_coo_scal(d,a,info,side)
a%val(i) = a%val(i) * d(j)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -162,6 +165,7 @@ subroutine psb_c_coo_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -170,6 +174,7 @@ subroutine psb_c_coo_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -269,11 +274,13 @@ subroutine psb_c_coo_reinit(a,clear)
clear_ = .true.
end if
if (a%is_dev()) call a%sync()
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = czero
call a%set_host()
call a%set_upd()
else
info = psb_err_invalid_mat_state_
@ -305,6 +312,7 @@ subroutine psb_c_coo_trim(a)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
nz = a%get_nzeros()
if (info == psb_success_) call psb_realloc(nz,a%ia,info)
if (info == psb_success_) call psb_realloc(nz,a%ja,info)
@ -372,6 +380,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
call a%set_dupl(psb_dupl_def_)
! An empty matrix is sorted!
call a%set_sorted(.true.)
call a%set_host()
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -411,6 +420,7 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -464,6 +474,7 @@ function psb_c_coo_get_nz_row(idx,a) result(res)
integer(psb_ipk_) :: res
integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k
if (a%is_dev()) call a%sync()
res = 0
nza = a%get_nzeros()
if (a%is_by_rows()) then
@ -534,7 +545,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (.not. (a%is_triangle())) then
info = psb_err_invalid_mat_state_
@ -895,7 +906,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
@ -1235,6 +1246,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1430,6 +1442,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1616,6 +1629,7 @@ function psb_c_coo_maxval(a) result(res)
character(len=20) :: name='c_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = sone
@ -1646,6 +1660,7 @@ function psb_c_coo_csnmi(a) result(res)
character(len=20) :: name='c_coo_csnmi'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = szero
nnz = a%get_nzeros()
@ -1707,6 +1722,7 @@ function psb_c_coo_csnm1(a) result(res)
character(len=20) :: name='c_coo_csnm1'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = szero
nnz = a%get_nzeros()
@ -1746,6 +1762,7 @@ subroutine psb_c_coo_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1794,6 +1811,7 @@ subroutine psb_c_coo_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1841,6 +1859,7 @@ subroutine psb_c_coo_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1889,6 +1908,7 @@ subroutine psb_c_coo_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1962,6 +1982,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2236,6 +2257,7 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
if (present(jmin)) then
@ -2514,6 +2536,7 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (nz < 0) then
info = psb_err_iarg_neg_
@ -2565,6 +2588,8 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then
if (a%is_dev()) call a%sync()
call c_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl)
@ -2584,6 +2609,7 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
call psb_errpush(info,name)
goto 9999
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -2883,6 +2909,8 @@ subroutine psb_c_cp_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
nz = a%get_nzeros()
@ -2893,6 +2921,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info)
b%ja(1:nz) = a%ja(1:nz)
b%val(1:nz) = a%val(1:nz)
call b%set_host()
if (.not.b%is_by_rows()) call b%fix(info)
@ -2924,6 +2953,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
nz = b%get_nzeros()
@ -2934,6 +2964,8 @@ subroutine psb_c_cp_coo_from_coo(a,b,info)
a%ja(1:nz) = b%ja(1:nz)
a%val(1:nz) = b%val(1:nz)
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3035,6 +3067,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
call b%set_nzeros(a%get_nzeros())
@ -3042,6 +3075,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info)
call move_alloc(a%ia, b%ia)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call b%set_host()
call a%free()
if (.not.b%is_by_rows()) call b%fix(info)
@ -3077,6 +3111,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
call a%set_nzeros(b%get_nzeros())
@ -3085,6 +3120,8 @@ subroutine psb_c_mv_coo_from_coo(a,b,info)
call move_alloc(b%ja , a%ja )
call move_alloc(b%val, a%val )
call b%free()
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3264,6 +3301,7 @@ subroutine psb_c_fix_coo(a,info,idir)
else
idir_ = psb_row_major_
endif
if (a%is_dev()) call a%sync()
nra = a%get_nrows()
nca = a%get_ncols()
@ -3278,7 +3316,7 @@ subroutine psb_c_fix_coo(a,info,idir)
call a%set_sort_status(idir_)
call a%set_nzeros(i)
call a%set_asb()
call a%set_host()
call psb_erractionrestore(err_act)
return

42
base/serial/impl/psb_c_csc_impl.f90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (a%is_dev()) call a%sync()
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
@ -377,6 +378,7 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
if (a%is_dev()) call a%sync()
nc = min(size(x,2) , size(y,2) )
@ -636,6 +638,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -854,7 +857,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -1068,6 +1071,7 @@ function psb_c_csc_maxval(a) result(res)
else
res = szero
end if
if (a%is_dev()) call a%sync()
nnz = a%get_nzeros()
if (allocated(a%val)) then
@ -1096,6 +1100,7 @@ function psb_c_csc_csnm1(a) result(res)
res = szero
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
is_unit = a%is_unit()
@ -1132,6 +1137,7 @@ subroutine psb_c_csc_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1179,6 +1185,7 @@ subroutine psb_c_csc_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1233,6 +1240,7 @@ subroutine psb_c_csc_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1282,6 +1290,7 @@ subroutine psb_c_csc_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1331,6 +1340,7 @@ subroutine psb_c_csc_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1388,6 +1398,7 @@ subroutine psb_c_csc_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
side_ = 'L'
if (present(side)) then
@ -1427,6 +1438,7 @@ subroutine psb_c_csc_scal(d,a,info,side)
end do
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1453,6 +1465,7 @@ subroutine psb_c_csc_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1461,6 +1474,7 @@ subroutine psb_c_csc_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1511,6 +1525,7 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1698,6 +1713,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1884,6 +1900,7 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = psb_success_
@ -1934,6 +1951,7 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2176,6 +2194,7 @@ subroutine psb_c_cp_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2218,6 +2237,7 @@ subroutine psb_c_mv_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2293,6 +2313,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info)
ip = ip + nrl
end do
a%icp(nc+1) = ip
call a%set_host()
end subroutine psb_c_mv_csc_from_coo
@ -2323,11 +2344,13 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_c_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat
call move_alloc(a%icp, b%icp)
call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2357,18 +2380,19 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info)
info = psb_success_
select type (b)
type is (psb_c_coo_sparse_mat)
call a%cp_to_coo(b,info)
type is (psb_c_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat
nc = a%get_ncols()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info)
if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2403,16 +2427,20 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_c_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat
call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_c_mv_csc_from_fmt
@ -2443,17 +2471,20 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_c_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat
nc = b%get_ncols()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info)
if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_c_cp_csc_from_fmt
@ -2597,6 +2628,7 @@ subroutine psb_c_csc_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2610,6 +2642,7 @@ subroutine psb_c_csc_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = czero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2704,6 +2737,7 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -2741,6 +2775,7 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2806,6 +2841,8 @@ subroutine psb_ccscspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -2828,6 +2865,7 @@ subroutine psb_ccscspspmm(a,b,c,info)
call csc_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

47
base/serial/impl/psb_c_csr_impl.f90
Unescape Escape View File

@ -65,6 +65,7 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -409,6 +410,7 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -758,6 +760,7 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1022,6 +1025,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1270,6 +1274,7 @@ function psb_c_csr_maxval(a) result(res)
character(len=20) :: name='c_csr_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = szero
nnz = a%get_nzeros()
@ -1296,6 +1301,7 @@ function psb_c_csr_csnmi(a) result(res)
res = szero
if (a%is_dev()) call a%sync()
do i = 1, a%get_nrows()
acc = dzero
@ -1324,6 +1330,7 @@ subroutine psb_c_csr_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1373,6 +1380,7 @@ subroutine psb_c_csr_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1422,6 +1430,7 @@ subroutine psb_c_csr_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1474,6 +1483,7 @@ subroutine psb_c_csr_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1525,6 +1535,7 @@ subroutine psb_c_csr_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1586,6 +1597,7 @@ subroutine psb_c_csr_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1627,7 +1639,7 @@ subroutine psb_c_csr_scal(d,a,info,side)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1659,6 +1671,7 @@ subroutine psb_c_csr_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1667,6 +1680,7 @@ subroutine psb_c_csr_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1814,6 +1828,7 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -1853,6 +1868,7 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2027,6 +2043,7 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2287,6 +2304,7 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
if (nz == 0) return
if (a%is_dev()) call a%sync()
nza = a%get_nzeros()
@ -2306,6 +2324,7 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2516,6 +2535,7 @@ subroutine psb_c_csr_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2529,6 +2549,7 @@ subroutine psb_c_csr_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = czero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2599,6 +2620,7 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2690,9 +2712,11 @@ subroutine psb_c_cp_csr_from_coo(a,b,info)
call move_alloc(tmp%val,a%val)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call tmp%free()
else
if (info /= psb_success_) return
if (b%is_dev()) call b%sync()
nr = b%get_nrows()
nc = b%get_ncols()
@ -2720,6 +2744,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_c_cp_csr_from_coo
@ -2746,6 +2771,7 @@ subroutine psb_c_cp_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2763,6 +2789,7 @@ subroutine psb_c_cp_csr_to_coo(a,b,info)
call b%set_nzeros(a%get_nzeros())
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_c_cp_csr_to_coo
@ -2788,6 +2815,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2806,6 +2834,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info)
call a%free()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_c_mv_csr_to_coo
@ -2835,6 +2864,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (b%is_dev()) call b%sync()
if (.not.b%is_by_rows()) call b%fix(info)
if (info /= psb_success_) return
@ -2865,7 +2895,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_c_mv_csr_from_coo
@ -2895,11 +2925,13 @@ subroutine psb_c_mv_csr_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_c_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat
call move_alloc(a%irp, b%irp)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2936,12 +2968,14 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info)
call a%cp_to_coo(b,info)
type is (psb_c_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat
nr = a%get_nrows()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info)
if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2976,11 +3010,14 @@ subroutine psb_c_mv_csr_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_c_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat
call move_alloc(b%irp, a%irp)
call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
@ -3017,12 +3054,14 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_c_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat
nr = b%get_nrows()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info)
if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
@ -3046,6 +3085,9 @@ subroutine psb_ccsrspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -3067,6 +3109,7 @@ subroutine psb_ccsrspspmm(a,b,c,info)
call csr_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

5
base/serial/impl/psb_d_base_mat_impl.F90
Unescape Escape View File

@ -367,9 +367,10 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (a%is_dev()) call a%sync()
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_

44
base/serial/impl/psb_d_coo_impl.f90
Unescape Escape View File

@ -46,6 +46,7 @@ subroutine psb_d_coo_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -96,6 +97,7 @@ subroutine psb_d_coo_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -135,6 +137,7 @@ subroutine psb_d_coo_scal(d,a,info,side)
a%val(i) = a%val(i) * d(j)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -162,6 +165,7 @@ subroutine psb_d_coo_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -170,6 +174,7 @@ subroutine psb_d_coo_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -269,11 +274,13 @@ subroutine psb_d_coo_reinit(a,clear)
clear_ = .true.
end if
if (a%is_dev()) call a%sync()
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
call a%set_host()
call a%set_upd()
else
info = psb_err_invalid_mat_state_
@ -305,6 +312,7 @@ subroutine psb_d_coo_trim(a)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
nz = a%get_nzeros()
if (info == psb_success_) call psb_realloc(nz,a%ia,info)
if (info == psb_success_) call psb_realloc(nz,a%ja,info)
@ -372,6 +380,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
call a%set_dupl(psb_dupl_def_)
! An empty matrix is sorted!
call a%set_sorted(.true.)
call a%set_host()
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -411,6 +420,7 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -464,6 +474,7 @@ function psb_d_coo_get_nz_row(idx,a) result(res)
integer(psb_ipk_) :: res
integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k
if (a%is_dev()) call a%sync()
res = 0
nza = a%get_nzeros()
if (a%is_by_rows()) then
@ -534,7 +545,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (.not. (a%is_triangle())) then
info = psb_err_invalid_mat_state_
@ -895,7 +906,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
@ -1235,6 +1246,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1430,6 +1442,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1616,6 +1629,7 @@ function psb_d_coo_maxval(a) result(res)
character(len=20) :: name='d_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = done
@ -1646,6 +1660,7 @@ function psb_d_coo_csnmi(a) result(res)
character(len=20) :: name='d_coo_csnmi'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = dzero
nnz = a%get_nzeros()
@ -1707,6 +1722,7 @@ function psb_d_coo_csnm1(a) result(res)
character(len=20) :: name='d_coo_csnm1'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = dzero
nnz = a%get_nzeros()
@ -1746,6 +1762,7 @@ subroutine psb_d_coo_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1794,6 +1811,7 @@ subroutine psb_d_coo_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1841,6 +1859,7 @@ subroutine psb_d_coo_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1889,6 +1908,7 @@ subroutine psb_d_coo_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1962,6 +1982,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2236,6 +2257,7 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
if (present(jmin)) then
@ -2514,6 +2536,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (nz < 0) then
info = psb_err_iarg_neg_
@ -2565,6 +2588,8 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then
if (a%is_dev()) call a%sync()
call d_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl)
@ -2584,6 +2609,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
call psb_errpush(info,name)
goto 9999
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -2883,6 +2909,8 @@ subroutine psb_d_cp_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
nz = a%get_nzeros()
@ -2893,6 +2921,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info)
b%ja(1:nz) = a%ja(1:nz)
b%val(1:nz) = a%val(1:nz)
call b%set_host()
if (.not.b%is_by_rows()) call b%fix(info)
@ -2924,6 +2953,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
nz = b%get_nzeros()
@ -2934,6 +2964,8 @@ subroutine psb_d_cp_coo_from_coo(a,b,info)
a%ja(1:nz) = b%ja(1:nz)
a%val(1:nz) = b%val(1:nz)
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3035,6 +3067,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
call b%set_nzeros(a%get_nzeros())
@ -3042,6 +3075,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info)
call move_alloc(a%ia, b%ia)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call b%set_host()
call a%free()
if (.not.b%is_by_rows()) call b%fix(info)
@ -3077,6 +3111,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
call a%set_nzeros(b%get_nzeros())
@ -3085,6 +3120,8 @@ subroutine psb_d_mv_coo_from_coo(a,b,info)
call move_alloc(b%ja , a%ja )
call move_alloc(b%val, a%val )
call b%free()
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3264,6 +3301,7 @@ subroutine psb_d_fix_coo(a,info,idir)
else
idir_ = psb_row_major_
endif
if (a%is_dev()) call a%sync()
nra = a%get_nrows()
nca = a%get_ncols()
@ -3278,7 +3316,7 @@ subroutine psb_d_fix_coo(a,info,idir)
call a%set_sort_status(idir_)
call a%set_nzeros(i)
call a%set_asb()
call a%set_host()
call psb_erractionrestore(err_act)
return

42
base/serial/impl/psb_d_csc_impl.f90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (a%is_dev()) call a%sync()
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
@ -377,6 +378,7 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
if (a%is_dev()) call a%sync()
nc = min(size(x,2) , size(y,2) )
@ -636,6 +638,7 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -854,7 +857,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -1068,6 +1071,7 @@ function psb_d_csc_maxval(a) result(res)
else
res = dzero
end if
if (a%is_dev()) call a%sync()
nnz = a%get_nzeros()
if (allocated(a%val)) then
@ -1096,6 +1100,7 @@ function psb_d_csc_csnm1(a) result(res)
res = dzero
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
is_unit = a%is_unit()
@ -1132,6 +1137,7 @@ subroutine psb_d_csc_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1179,6 +1185,7 @@ subroutine psb_d_csc_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1233,6 +1240,7 @@ subroutine psb_d_csc_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1282,6 +1290,7 @@ subroutine psb_d_csc_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1331,6 +1340,7 @@ subroutine psb_d_csc_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1388,6 +1398,7 @@ subroutine psb_d_csc_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
side_ = 'L'
if (present(side)) then
@ -1427,6 +1438,7 @@ subroutine psb_d_csc_scal(d,a,info,side)
end do
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1453,6 +1465,7 @@ subroutine psb_d_csc_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1461,6 +1474,7 @@ subroutine psb_d_csc_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1511,6 +1525,7 @@ subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1698,6 +1713,7 @@ subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1884,6 +1900,7 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = psb_success_
@ -1934,6 +1951,7 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2176,6 +2194,7 @@ subroutine psb_d_cp_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2218,6 +2237,7 @@ subroutine psb_d_mv_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2293,6 +2313,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info)
ip = ip + nrl
end do
a%icp(nc+1) = ip
call a%set_host()
end subroutine psb_d_mv_csc_from_coo
@ -2323,11 +2344,13 @@ subroutine psb_d_mv_csc_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_d_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat
call move_alloc(a%icp, b%icp)
call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2357,18 +2380,19 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info)
info = psb_success_
select type (b)
type is (psb_d_coo_sparse_mat)
call a%cp_to_coo(b,info)
type is (psb_d_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat
nc = a%get_ncols()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info)
if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2403,16 +2427,20 @@ subroutine psb_d_mv_csc_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_d_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_d_mv_csc_from_fmt
@ -2443,17 +2471,20 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_d_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
nc = b%get_ncols()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info)
if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_d_cp_csc_from_fmt
@ -2597,6 +2628,7 @@ subroutine psb_d_csc_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2610,6 +2642,7 @@ subroutine psb_d_csc_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2704,6 +2737,7 @@ subroutine psb_d_csc_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -2741,6 +2775,7 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2806,6 +2841,8 @@ subroutine psb_dcscspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -2828,6 +2865,7 @@ subroutine psb_dcscspspmm(a,b,c,info)
call csc_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

47
base/serial/impl/psb_d_csr_impl.f90
Unescape Escape View File

@ -65,6 +65,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -409,6 +410,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -758,6 +760,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1022,6 +1025,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1270,6 +1274,7 @@ function psb_d_csr_maxval(a) result(res)
character(len=20) :: name='d_csr_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = dzero
nnz = a%get_nzeros()
@ -1296,6 +1301,7 @@ function psb_d_csr_csnmi(a) result(res)
res = dzero
if (a%is_dev()) call a%sync()
do i = 1, a%get_nrows()
acc = dzero
@ -1324,6 +1330,7 @@ subroutine psb_d_csr_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1373,6 +1380,7 @@ subroutine psb_d_csr_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1422,6 +1430,7 @@ subroutine psb_d_csr_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1474,6 +1483,7 @@ subroutine psb_d_csr_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1525,6 +1535,7 @@ subroutine psb_d_csr_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1586,6 +1597,7 @@ subroutine psb_d_csr_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1627,7 +1639,7 @@ subroutine psb_d_csr_scal(d,a,info,side)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1659,6 +1671,7 @@ subroutine psb_d_csr_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1667,6 +1680,7 @@ subroutine psb_d_csr_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1814,6 +1828,7 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -1853,6 +1868,7 @@ subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2027,6 +2043,7 @@ subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2287,6 +2304,7 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
if (nz == 0) return
if (a%is_dev()) call a%sync()
nza = a%get_nzeros()
@ -2306,6 +2324,7 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2516,6 +2535,7 @@ subroutine psb_d_csr_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2529,6 +2549,7 @@ subroutine psb_d_csr_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2599,6 +2620,7 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2690,9 +2712,11 @@ subroutine psb_d_cp_csr_from_coo(a,b,info)
call move_alloc(tmp%val,a%val)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call tmp%free()
else
if (info /= psb_success_) return
if (b%is_dev()) call b%sync()
nr = b%get_nrows()
nc = b%get_ncols()
@ -2720,6 +2744,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_d_cp_csr_from_coo
@ -2746,6 +2771,7 @@ subroutine psb_d_cp_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2763,6 +2789,7 @@ subroutine psb_d_cp_csr_to_coo(a,b,info)
call b%set_nzeros(a%get_nzeros())
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_d_cp_csr_to_coo
@ -2788,6 +2815,7 @@ subroutine psb_d_mv_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2806,6 +2834,7 @@ subroutine psb_d_mv_csr_to_coo(a,b,info)
call a%free()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_d_mv_csr_to_coo
@ -2835,6 +2864,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (b%is_dev()) call b%sync()
if (.not.b%is_by_rows()) call b%fix(info)
if (info /= psb_success_) return
@ -2865,7 +2895,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_d_mv_csr_from_coo
@ -2895,11 +2925,13 @@ subroutine psb_d_mv_csr_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_d_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat
call move_alloc(a%irp, b%irp)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2936,12 +2968,14 @@ subroutine psb_d_cp_csr_to_fmt(a,b,info)
call a%cp_to_coo(b,info)
type is (psb_d_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat
nr = a%get_nrows()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info)
if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2976,11 +3010,14 @@ subroutine psb_d_mv_csr_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_d_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
call move_alloc(b%irp, a%irp)
call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
@ -3017,12 +3054,14 @@ subroutine psb_d_cp_csr_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_d_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
nr = b%get_nrows()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info)
if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
@ -3046,6 +3085,9 @@ subroutine psb_dcsrspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -3067,6 +3109,7 @@ subroutine psb_dcsrspspmm(a,b,c,info)
call csr_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

5
base/serial/impl/psb_s_base_mat_impl.F90
Unescape Escape View File

@ -367,9 +367,10 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (a%is_dev()) call a%sync()
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_

44
base/serial/impl/psb_s_coo_impl.f90
Unescape Escape View File

@ -46,6 +46,7 @@ subroutine psb_s_coo_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -96,6 +97,7 @@ subroutine psb_s_coo_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -135,6 +137,7 @@ subroutine psb_s_coo_scal(d,a,info,side)
a%val(i) = a%val(i) * d(j)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -162,6 +165,7 @@ subroutine psb_s_coo_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -170,6 +174,7 @@ subroutine psb_s_coo_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -269,11 +274,13 @@ subroutine psb_s_coo_reinit(a,clear)
clear_ = .true.
end if
if (a%is_dev()) call a%sync()
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = szero
call a%set_host()
call a%set_upd()
else
info = psb_err_invalid_mat_state_
@ -305,6 +312,7 @@ subroutine psb_s_coo_trim(a)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
nz = a%get_nzeros()
if (info == psb_success_) call psb_realloc(nz,a%ia,info)
if (info == psb_success_) call psb_realloc(nz,a%ja,info)
@ -372,6 +380,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
call a%set_dupl(psb_dupl_def_)
! An empty matrix is sorted!
call a%set_sorted(.true.)
call a%set_host()
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -411,6 +420,7 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -464,6 +474,7 @@ function psb_s_coo_get_nz_row(idx,a) result(res)
integer(psb_ipk_) :: res
integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k
if (a%is_dev()) call a%sync()
res = 0
nza = a%get_nzeros()
if (a%is_by_rows()) then
@ -534,7 +545,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (.not. (a%is_triangle())) then
info = psb_err_invalid_mat_state_
@ -895,7 +906,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
@ -1235,6 +1246,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1430,6 +1442,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1616,6 +1629,7 @@ function psb_s_coo_maxval(a) result(res)
character(len=20) :: name='s_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = sone
@ -1646,6 +1660,7 @@ function psb_s_coo_csnmi(a) result(res)
character(len=20) :: name='s_coo_csnmi'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = szero
nnz = a%get_nzeros()
@ -1707,6 +1722,7 @@ function psb_s_coo_csnm1(a) result(res)
character(len=20) :: name='s_coo_csnm1'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = szero
nnz = a%get_nzeros()
@ -1746,6 +1762,7 @@ subroutine psb_s_coo_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1794,6 +1811,7 @@ subroutine psb_s_coo_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1841,6 +1859,7 @@ subroutine psb_s_coo_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1889,6 +1908,7 @@ subroutine psb_s_coo_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1962,6 +1982,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2236,6 +2257,7 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
if (present(jmin)) then
@ -2514,6 +2536,7 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (nz < 0) then
info = psb_err_iarg_neg_
@ -2565,6 +2588,8 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then
if (a%is_dev()) call a%sync()
call s_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl)
@ -2584,6 +2609,7 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
call psb_errpush(info,name)
goto 9999
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -2883,6 +2909,8 @@ subroutine psb_s_cp_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
nz = a%get_nzeros()
@ -2893,6 +2921,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info)
b%ja(1:nz) = a%ja(1:nz)
b%val(1:nz) = a%val(1:nz)
call b%set_host()
if (.not.b%is_by_rows()) call b%fix(info)
@ -2924,6 +2953,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
nz = b%get_nzeros()
@ -2934,6 +2964,8 @@ subroutine psb_s_cp_coo_from_coo(a,b,info)
a%ja(1:nz) = b%ja(1:nz)
a%val(1:nz) = b%val(1:nz)
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3035,6 +3067,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
call b%set_nzeros(a%get_nzeros())
@ -3042,6 +3075,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info)
call move_alloc(a%ia, b%ia)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call b%set_host()
call a%free()
if (.not.b%is_by_rows()) call b%fix(info)
@ -3077,6 +3111,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
call a%set_nzeros(b%get_nzeros())
@ -3085,6 +3120,8 @@ subroutine psb_s_mv_coo_from_coo(a,b,info)
call move_alloc(b%ja , a%ja )
call move_alloc(b%val, a%val )
call b%free()
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3264,6 +3301,7 @@ subroutine psb_s_fix_coo(a,info,idir)
else
idir_ = psb_row_major_
endif
if (a%is_dev()) call a%sync()
nra = a%get_nrows()
nca = a%get_ncols()
@ -3278,7 +3316,7 @@ subroutine psb_s_fix_coo(a,info,idir)
call a%set_sort_status(idir_)
call a%set_nzeros(i)
call a%set_asb()
call a%set_host()
call psb_erractionrestore(err_act)
return

42
base/serial/impl/psb_s_csc_impl.f90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (a%is_dev()) call a%sync()
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
@ -377,6 +378,7 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
if (a%is_dev()) call a%sync()
nc = min(size(x,2) , size(y,2) )
@ -636,6 +638,7 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -854,7 +857,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -1068,6 +1071,7 @@ function psb_s_csc_maxval(a) result(res)
else
res = szero
end if
if (a%is_dev()) call a%sync()
nnz = a%get_nzeros()
if (allocated(a%val)) then
@ -1096,6 +1100,7 @@ function psb_s_csc_csnm1(a) result(res)
res = szero
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
is_unit = a%is_unit()
@ -1132,6 +1137,7 @@ subroutine psb_s_csc_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1179,6 +1185,7 @@ subroutine psb_s_csc_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1233,6 +1240,7 @@ subroutine psb_s_csc_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1282,6 +1290,7 @@ subroutine psb_s_csc_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1331,6 +1340,7 @@ subroutine psb_s_csc_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1388,6 +1398,7 @@ subroutine psb_s_csc_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
side_ = 'L'
if (present(side)) then
@ -1427,6 +1438,7 @@ subroutine psb_s_csc_scal(d,a,info,side)
end do
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1453,6 +1465,7 @@ subroutine psb_s_csc_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1461,6 +1474,7 @@ subroutine psb_s_csc_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1511,6 +1525,7 @@ subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1698,6 +1713,7 @@ subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1884,6 +1900,7 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = psb_success_
@ -1934,6 +1951,7 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2176,6 +2194,7 @@ subroutine psb_s_cp_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2218,6 +2237,7 @@ subroutine psb_s_mv_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2293,6 +2313,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info)
ip = ip + nrl
end do
a%icp(nc+1) = ip
call a%set_host()
end subroutine psb_s_mv_csc_from_coo
@ -2323,11 +2344,13 @@ subroutine psb_s_mv_csc_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_s_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat
call move_alloc(a%icp, b%icp)
call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2357,18 +2380,19 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info)
info = psb_success_
select type (b)
type is (psb_s_coo_sparse_mat)
call a%cp_to_coo(b,info)
type is (psb_s_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat
nc = a%get_ncols()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info)
if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2403,16 +2427,20 @@ subroutine psb_s_mv_csc_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_s_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat
call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_s_mv_csc_from_fmt
@ -2443,17 +2471,20 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_s_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat
nc = b%get_ncols()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info)
if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_s_cp_csc_from_fmt
@ -2597,6 +2628,7 @@ subroutine psb_s_csc_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2610,6 +2642,7 @@ subroutine psb_s_csc_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = szero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2704,6 +2737,7 @@ subroutine psb_s_csc_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -2741,6 +2775,7 @@ subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2806,6 +2841,8 @@ subroutine psb_scscspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -2828,6 +2865,7 @@ subroutine psb_scscspspmm(a,b,c,info)
call csc_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

47
base/serial/impl/psb_s_csr_impl.f90
Unescape Escape View File

@ -65,6 +65,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -409,6 +410,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -758,6 +760,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1022,6 +1025,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1270,6 +1274,7 @@ function psb_s_csr_maxval(a) result(res)
character(len=20) :: name='s_csr_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = szero
nnz = a%get_nzeros()
@ -1296,6 +1301,7 @@ function psb_s_csr_csnmi(a) result(res)
res = szero
if (a%is_dev()) call a%sync()
do i = 1, a%get_nrows()
acc = dzero
@ -1324,6 +1330,7 @@ subroutine psb_s_csr_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1373,6 +1380,7 @@ subroutine psb_s_csr_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1422,6 +1430,7 @@ subroutine psb_s_csr_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1474,6 +1483,7 @@ subroutine psb_s_csr_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1525,6 +1535,7 @@ subroutine psb_s_csr_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1586,6 +1597,7 @@ subroutine psb_s_csr_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1627,7 +1639,7 @@ subroutine psb_s_csr_scal(d,a,info,side)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1659,6 +1671,7 @@ subroutine psb_s_csr_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1667,6 +1680,7 @@ subroutine psb_s_csr_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1814,6 +1828,7 @@ subroutine psb_s_csr_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -1853,6 +1868,7 @@ subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2027,6 +2043,7 @@ subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2287,6 +2304,7 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
if (nz == 0) return
if (a%is_dev()) call a%sync()
nza = a%get_nzeros()
@ -2306,6 +2324,7 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2516,6 +2535,7 @@ subroutine psb_s_csr_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2529,6 +2549,7 @@ subroutine psb_s_csr_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = szero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2599,6 +2620,7 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2690,9 +2712,11 @@ subroutine psb_s_cp_csr_from_coo(a,b,info)
call move_alloc(tmp%val,a%val)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call tmp%free()
else
if (info /= psb_success_) return
if (b%is_dev()) call b%sync()
nr = b%get_nrows()
nc = b%get_ncols()
@ -2720,6 +2744,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_s_cp_csr_from_coo
@ -2746,6 +2771,7 @@ subroutine psb_s_cp_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2763,6 +2789,7 @@ subroutine psb_s_cp_csr_to_coo(a,b,info)
call b%set_nzeros(a%get_nzeros())
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_s_cp_csr_to_coo
@ -2788,6 +2815,7 @@ subroutine psb_s_mv_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2806,6 +2834,7 @@ subroutine psb_s_mv_csr_to_coo(a,b,info)
call a%free()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_s_mv_csr_to_coo
@ -2835,6 +2864,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (b%is_dev()) call b%sync()
if (.not.b%is_by_rows()) call b%fix(info)
if (info /= psb_success_) return
@ -2865,7 +2895,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_s_mv_csr_from_coo
@ -2895,11 +2925,13 @@ subroutine psb_s_mv_csr_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_s_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat
call move_alloc(a%irp, b%irp)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2936,12 +2968,14 @@ subroutine psb_s_cp_csr_to_fmt(a,b,info)
call a%cp_to_coo(b,info)
type is (psb_s_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat
nr = a%get_nrows()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info)
if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2976,11 +3010,14 @@ subroutine psb_s_mv_csr_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_s_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat
call move_alloc(b%irp, a%irp)
call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
@ -3017,12 +3054,14 @@ subroutine psb_s_cp_csr_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_s_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat
nr = b%get_nrows()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info)
if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
@ -3046,6 +3085,9 @@ subroutine psb_scsrspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -3067,6 +3109,7 @@ subroutine psb_scsrspspmm(a,b,c,info)
call csr_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

5
base/serial/impl/psb_z_base_mat_impl.F90
Unescape Escape View File

@ -367,9 +367,10 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (a%is_dev()) call a%sync()
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_

44
base/serial/impl/psb_z_coo_impl.f90
Unescape Escape View File

@ -46,6 +46,7 @@ subroutine psb_z_coo_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -96,6 +97,7 @@ subroutine psb_z_coo_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -135,6 +137,7 @@ subroutine psb_z_coo_scal(d,a,info,side)
a%val(i) = a%val(i) * d(j)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -162,6 +165,7 @@ subroutine psb_z_coo_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -170,6 +174,7 @@ subroutine psb_z_coo_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -269,11 +274,13 @@ subroutine psb_z_coo_reinit(a,clear)
clear_ = .true.
end if
if (a%is_dev()) call a%sync()
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = zzero
call a%set_host()
call a%set_upd()
else
info = psb_err_invalid_mat_state_
@ -305,6 +312,7 @@ subroutine psb_z_coo_trim(a)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
nz = a%get_nzeros()
if (info == psb_success_) call psb_realloc(nz,a%ia,info)
if (info == psb_success_) call psb_realloc(nz,a%ja,info)
@ -372,6 +380,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
call a%set_dupl(psb_dupl_def_)
! An empty matrix is sorted!
call a%set_sorted(.true.)
call a%set_host()
end if
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -411,6 +420,7 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -464,6 +474,7 @@ function psb_z_coo_get_nz_row(idx,a) result(res)
integer(psb_ipk_) :: res
integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k
if (a%is_dev()) call a%sync()
res = 0
nza = a%get_nzeros()
if (a%is_by_rows()) then
@ -534,7 +545,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (.not. (a%is_triangle())) then
info = psb_err_invalid_mat_state_
@ -895,7 +906,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
@ -1235,6 +1246,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1430,6 +1442,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -1616,6 +1629,7 @@ function psb_z_coo_maxval(a) result(res)
character(len=20) :: name='z_coo_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
res = done
@ -1646,6 +1660,7 @@ function psb_z_coo_csnmi(a) result(res)
character(len=20) :: name='z_coo_csnmi'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = dzero
nnz = a%get_nzeros()
@ -1707,6 +1722,7 @@ function psb_z_coo_csnm1(a) result(res)
character(len=20) :: name='z_coo_csnm1'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = dzero
nnz = a%get_nzeros()
@ -1746,6 +1762,7 @@ subroutine psb_z_coo_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1794,6 +1811,7 @@ subroutine psb_z_coo_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1841,6 +1859,7 @@ subroutine psb_z_coo_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1889,6 +1908,7 @@ subroutine psb_z_coo_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
n = a%get_ncols()
if (size(d) < n) then
@ -1962,6 +1982,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2236,6 +2257,7 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
if (present(jmin)) then
@ -2514,6 +2536,7 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (nz < 0) then
info = psb_err_iarg_neg_
@ -2565,6 +2588,8 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then
if (a%is_dev()) call a%sync()
call z_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl)
@ -2584,6 +2609,7 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
call psb_errpush(info,name)
goto 9999
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -2883,6 +2909,8 @@ subroutine psb_z_cp_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
nz = a%get_nzeros()
@ -2893,6 +2921,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info)
b%ja(1:nz) = a%ja(1:nz)
b%val(1:nz) = a%val(1:nz)
call b%set_host()
if (.not.b%is_by_rows()) call b%fix(info)
@ -2924,6 +2953,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
nz = b%get_nzeros()
@ -2934,6 +2964,8 @@ subroutine psb_z_cp_coo_from_coo(a,b,info)
a%ja(1:nz) = b%ja(1:nz)
a%val(1:nz) = b%val(1:nz)
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3035,6 +3067,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat
call b%set_sort_status(a%get_sort_status())
call b%set_nzeros(a%get_nzeros())
@ -3042,6 +3075,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info)
call move_alloc(a%ia, b%ia)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call b%set_host()
call a%free()
if (.not.b%is_by_rows()) call b%fix(info)
@ -3077,6 +3111,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info)
call psb_erractionsave(err_act)
info = psb_success_
if (b%is_dev()) call b%sync()
a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat
call a%set_sort_status(b%get_sort_status())
call a%set_nzeros(b%get_nzeros())
@ -3085,6 +3120,8 @@ subroutine psb_z_mv_coo_from_coo(a,b,info)
call move_alloc(b%ja , a%ja )
call move_alloc(b%val, a%val )
call b%free()
call a%set_host()
if (.not.a%is_by_rows()) call a%fix(info)
if (info /= psb_success_) goto 9999
@ -3264,6 +3301,7 @@ subroutine psb_z_fix_coo(a,info,idir)
else
idir_ = psb_row_major_
endif
if (a%is_dev()) call a%sync()
nra = a%get_nrows()
nca = a%get_ncols()
@ -3278,7 +3316,7 @@ subroutine psb_z_fix_coo(a,info,idir)
call a%set_sort_status(idir_)
call a%set_nzeros(i)
call a%set_asb()
call a%set_host()
call psb_erractionrestore(err_act)
return

42
base/serial/impl/psb_z_csc_impl.f90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
end if
if (a%is_dev()) call a%sync()
if (size(x,1)<n) then
info = psb_err_input_asize_small_i_
@ -377,6 +378,7 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
if (a%is_dev()) call a%sync()
nc = min(size(x,2) , size(y,2) )
@ -636,6 +638,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -854,7 +857,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
if (a%is_dev()) call a%sync()
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
@ -1068,6 +1071,7 @@ function psb_z_csc_maxval(a) result(res)
else
res = dzero
end if
if (a%is_dev()) call a%sync()
nnz = a%get_nzeros()
if (allocated(a%val)) then
@ -1096,6 +1100,7 @@ function psb_z_csc_csnm1(a) result(res)
res = dzero
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
is_unit = a%is_unit()
@ -1132,6 +1137,7 @@ subroutine psb_z_csc_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1179,6 +1185,7 @@ subroutine psb_z_csc_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
if (size(d) < m) then
@ -1233,6 +1240,7 @@ subroutine psb_z_csc_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1282,6 +1290,7 @@ subroutine psb_z_csc_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_ncols()
n = a%get_nrows()
@ -1331,6 +1340,7 @@ subroutine psb_z_csc_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1388,6 +1398,7 @@ subroutine psb_z_csc_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
side_ = 'L'
if (present(side)) then
@ -1427,6 +1438,7 @@ subroutine psb_z_csc_scal(d,a,info,side)
end do
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1453,6 +1465,7 @@ subroutine psb_z_csc_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1461,6 +1474,7 @@ subroutine psb_z_csc_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1511,6 +1525,7 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1698,6 +1713,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -1884,6 +1900,7 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = psb_success_
@ -1934,6 +1951,7 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2176,6 +2194,7 @@ subroutine psb_z_cp_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2218,6 +2237,7 @@ subroutine psb_z_mv_csc_to_coo(a,b,info)
character(len=20) :: name
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2293,6 +2313,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info)
ip = ip + nrl
end do
a%icp(nc+1) = ip
call a%set_host()
end subroutine psb_z_mv_csc_from_coo
@ -2323,11 +2344,13 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_z_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat
call move_alloc(a%icp, b%icp)
call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2357,18 +2380,19 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info)
info = psb_success_
select type (b)
type is (psb_z_coo_sparse_mat)
call a%cp_to_coo(b,info)
type is (psb_z_csc_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat
nc = a%get_ncols()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info)
if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2403,16 +2427,20 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_z_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat
call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_z_mv_csc_from_fmt
@ -2443,17 +2471,20 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_z_csc_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat
nc = b%get_ncols()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info)
if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select
call a%set_host()
end subroutine psb_z_cp_csc_from_fmt
@ -2597,6 +2628,7 @@ subroutine psb_z_csc_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2610,6 +2642,7 @@ subroutine psb_z_csc_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = zzero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2704,6 +2737,7 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -2741,6 +2775,7 @@ subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2806,6 +2841,8 @@ subroutine psb_zcscspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -2828,6 +2865,7 @@ subroutine psb_zcscspspmm(a,b,c,info)
call csc_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

47
base/serial/impl/psb_z_csr_impl.f90
Unescape Escape View File

@ -65,6 +65,7 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -409,6 +410,7 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
@ -758,6 +760,7 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1022,6 +1025,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (present(trans)) then
trans_ = trans
else
@ -1270,6 +1274,7 @@ function psb_z_csr_maxval(a) result(res)
character(len=20) :: name='z_csr_maxval'
logical, parameter :: debug=.false.
if (a%is_dev()) call a%sync()
res = dzero
nnz = a%get_nzeros()
@ -1296,6 +1301,7 @@ function psb_z_csr_csnmi(a) result(res)
res = dzero
if (a%is_dev()) call a%sync()
do i = 1, a%get_nrows()
acc = dzero
@ -1324,6 +1330,7 @@ subroutine psb_z_csr_rowsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1373,6 +1380,7 @@ subroutine psb_z_csr_arwsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
@ -1422,6 +1430,7 @@ subroutine psb_z_csr_colsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1474,6 +1483,7 @@ subroutine psb_z_csr_aclsum(d,a)
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
n = a%get_ncols()
@ -1525,6 +1535,7 @@ subroutine psb_z_csr_get_diag(a,d,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
@ -1586,6 +1597,7 @@ subroutine psb_z_csr_scal(d,a,info,side)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1627,7 +1639,7 @@ subroutine psb_z_csr_scal(d,a,info,side)
enddo
end if
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1659,6 +1671,7 @@ subroutine psb_z_csr_scals(d,a,info)
info = psb_success_
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
if (a%is_unit()) then
call a%make_nonunit()
@ -1667,6 +1680,7 @@ subroutine psb_z_csr_scals(d,a,info)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
call a%set_host()
call psb_erractionrestore(err_act)
return
@ -1814,6 +1828,7 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz)
call a%set_triangle(.false.)
call a%set_unit(.false.)
call a%set_dupl(psb_dupl_def_)
call a%set_host()
end if
call psb_erractionrestore(err_act)
@ -1853,6 +1868,7 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2027,6 +2043,7 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (a%is_dev()) call a%sync()
info = psb_success_
nz = 0
@ -2287,6 +2304,7 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
if (nz == 0) return
if (a%is_dev()) call a%sync()
nza = a%get_nzeros()
@ -2306,6 +2324,7 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
& ': Discarded entries not belonging to us.'
info = psb_success_
end if
call a%set_host()
else
! State is wrong.
@ -2516,6 +2535,7 @@ subroutine psb_z_csr_reinit(a,clear)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (present(clear)) then
clear_ = clear
@ -2529,6 +2549,7 @@ subroutine psb_z_csr_reinit(a,clear)
else if (a%is_asb()) then
if (clear_) a%val(:) = zzero
call a%set_upd()
call a%set_host()
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
@ -2599,6 +2620,7 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc)
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
@ -2690,9 +2712,11 @@ subroutine psb_z_cp_csr_from_coo(a,b,info)
call move_alloc(tmp%val,a%val)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call tmp%free()
else
if (info /= psb_success_) return
if (b%is_dev()) call b%sync()
nr = b%get_nrows()
nc = b%get_ncols()
@ -2720,6 +2744,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_z_cp_csr_from_coo
@ -2746,6 +2771,7 @@ subroutine psb_z_cp_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2763,6 +2789,7 @@ subroutine psb_z_cp_csr_to_coo(a,b,info)
call b%set_nzeros(a%get_nzeros())
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_z_cp_csr_to_coo
@ -2788,6 +2815,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info)
info = psb_success_
if (a%is_dev()) call a%sync()
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
@ -2806,6 +2834,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info)
call a%free()
call b%set_sort_status(psb_row_major_)
call b%set_asb()
call b%set_host()
end subroutine psb_z_mv_csr_to_coo
@ -2835,6 +2864,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (b%is_dev()) call b%sync()
if (.not.b%is_by_rows()) call b%fix(info)
if (info /= psb_success_) return
@ -2865,7 +2895,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info)
ip = ip + ncl
end do
a%irp(nr+1) = ip
call a%set_host()
end subroutine psb_z_mv_csr_from_coo
@ -2895,11 +2925,13 @@ subroutine psb_z_mv_csr_to_fmt(a,b,info)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
type is (psb_z_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat
call move_alloc(a%irp, b%irp)
call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val)
call a%free()
call b%set_host()
class default
call a%mv_to_coo(tmp,info)
@ -2936,12 +2968,14 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info)
call a%cp_to_coo(b,info)
type is (psb_z_csr_sparse_mat)
if (a%is_dev()) call a%sync()
b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat
nr = a%get_nrows()
nz = a%get_nzeros()
if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info)
if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info)
if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info)
call b%set_host()
class default
call a%cp_to_coo(tmp,info)
@ -2976,11 +3010,14 @@ subroutine psb_z_mv_csr_from_fmt(a,b,info)
call a%mv_from_coo(b,info)
type is (psb_z_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat
call move_alloc(b%irp, a%irp)
call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val)
call b%free()
call a%set_host()
class default
call b%mv_to_coo(tmp,info)
@ -3017,12 +3054,14 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info)
call a%cp_from_coo(b,info)
type is (psb_z_csr_sparse_mat)
if (b%is_dev()) call b%sync()
a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat
nr = b%get_nrows()
nz = b%get_nzeros()
if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info)
if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info)
if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info)
call a%set_host()
class default
call b%cp_to_coo(tmp,info)
@ -3046,6 +3085,9 @@ subroutine psb_zcsrspspmm(a,b,c,info)
call psb_erractionsave(err_act)
info = psb_success_
if (a%is_dev()) call a%sync()
if (b%is_dev()) call b%sync()
ma = a%get_nrows()
na = a%get_ncols()
mb = b%get_nrows()
@ -3067,6 +3109,7 @@ subroutine psb_zcsrspspmm(a,b,c,info)
call csr_spspmm(a,b,c,info)
call c%set_asb()
call c%set_host()
call psb_erractionrestore(err_act)
return

122
base/tools/psb_cspins.f90
Unescape Escape View File

@ -129,7 +129,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@ -274,7 +275,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@ -385,44 +387,47 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
else
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='psb_cdins',i_err=ierr)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
endif
else if (desc_a%is_asb()) then
@ -436,24 +441,25 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info)
if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
end if
else
info = psb_err_invalid_cd_state_

122
base/tools/psb_dspins.f90
Unescape Escape View File

@ -129,7 +129,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@ -274,7 +275,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@ -385,44 +387,47 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
else
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='psb_cdins',i_err=ierr)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
endif
else if (desc_a%is_asb()) then
@ -436,24 +441,25 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info)
if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
end if
else
info = psb_err_invalid_cd_state_

122
base/tools/psb_sspins.f90
Unescape Escape View File

@ -129,7 +129,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@ -274,7 +275,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@ -385,44 +387,47 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
else
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='psb_cdins',i_err=ierr)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
endif
else if (desc_a%is_asb()) then
@ -436,24 +441,25 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info)
if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
end if
else
info = psb_err_invalid_cd_state_

122
base/tools/psb_zspins.f90
Unescape Escape View File

@ -129,7 +129,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@ -274,7 +275,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,&
& mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@ -385,44 +387,47 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
else
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='psb_cdins',i_err=ierr)
goto 9999
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
end if
endif
else if (desc_a%is_asb()) then
@ -436,24 +441,25 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate',i_err=ierr)
goto 9999
end if
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
if (val%is_dev()) call val%sync()
call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info)
if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
end if
else
info = psb_err_invalid_cd_state_

2
util/Makefile
Unescape Escape View File

@ -12,7 +12,7 @@ BASEOBJS= psb_blockpart_mod.o psb_metispart_mod.o \
IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \
psb_c_hbio_impl.o psb_z_hbio_impl.o \
psb_s_mmio_impl.o psb_d_mmio_impl.o \
psb_c_mmio_impl.o psb_z_mmio_impl.o \
psb_c_mmio_impl.o psb_z_mmio_impl.o psb_i_mmio_impl.o\
psb_s_mat_dist_impl.o psb_d_mat_dist_impl.o \
psb_c_mat_dist_impl.o psb_z_mat_dist_impl.o \
psb_s_renum_impl.o psb_d_renum_impl.o \

286
util/psb_i_mmio_impl.f90
Unescape Escape View File

@ -0,0 +1,286 @@
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
!!$ 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.
!!$
!!$
!
! Warning: MM does not define a format for an array with integer entries.
! Hence we hijack the REAL format, but this could lead to errors when
! used with non-integer files.
!
subroutine mm_ivet_read(b, info, iunit, filename)
use psb_base_mod
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
integer(psb_ipk_) :: nrow, ncol, i,root, np, me, ircode, j, infile
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
info = psb_success_
if (present(filename)) then
if (filename == '-') then
infile=5
else
if (present(iunit)) then
infile=iunit
else
infile=99
endif
open(infile,file=filename, status='OLD', err=901, action='READ')
endif
else
if (present(iunit)) then
infile=iunit
else
infile=5
endif
endif
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(psb_err_unit,*) 'read_rhs: input file type not yet supported'
info = -3
return
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow),stat = ircode)
if (ircode /= 0) goto 993
do i=1,nrow
read(infile,fmt=*,end=902) b(i)
end do
end if ! read right hand sides
if (infile /= 5) close(infile)
return
! open failed
901 write(psb_err_unit,*) 'mm_vet_read: could not open file ',&
& infile,' for input'
info = -1
return
902 write(psb_err_unit,*) 'mmv_vet_read: unexpected end of file ',infile,&
& ' during input'
info = -2
return
993 write(psb_err_unit,*) 'mm_vet_read: memory allocation failure'
info = -3
return
end subroutine mm_ivet_read
subroutine mm_ivet2_read(b, info, iunit, filename)
use psb_base_mod
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
integer(psb_ipk_) :: nrow, ncol, i,root, np, me, ircode, j, infile
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
info = psb_success_
if (present(filename)) then
if (filename == '-') then
infile=5
else
if (present(iunit)) then
infile=iunit
else
infile=99
endif
open(infile,file=filename, status='OLD', err=901, action='READ')
endif
else
if (present(iunit)) then
infile=iunit
else
infile=5
endif
endif
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(psb_err_unit,*) 'read_rhs: input file type not yet supported'
info = -3
return
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol)
end if ! read right hand sides
if (infile /= 5) close(infile)
return
! open failed
901 write(psb_err_unit,*) 'mm_vet_read: could not open file ',&
& infile,' for input'
info = -1
return
902 write(psb_err_unit,*) 'mmv_vet_read: unexpected end of file ',infile,&
& ' during input'
info = -2
return
993 write(psb_err_unit,*) 'mm_vet_read: memory allocation failure'
info = -3
return
end subroutine mm_ivet2_read
subroutine mm_ivet2_write(b, header, info, iunit, filename)
use psb_base_mod
implicit none
integer(psb_ipk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
integer(psb_ipk_) :: nrow, ncol, i,root, np, me, ircode, j, outfile
character(len=80) :: frmtv
info = psb_success_
if (present(filename)) then
if (filename == '-') then
outfile=6
else
if (present(iunit)) then
outfile=iunit
else
outfile=99
endif
open(outfile,file=filename, err=901, action='WRITE')
endif
else
if (present(iunit)) then
outfile=iunit
else
outfile=6
endif
endif
write(outfile,'(a)') '%%MatrixMarket matrix array real general'
write(outfile,'(a)') '% '//trim(header)
write(outfile,'(a)') '% '
nrow = size(b,1)
ncol = size(b,2)
write(outfile,*) nrow, ncol
write(outfile,fmt='(I14,1x)') ((b(i,j), i=1,nrow),j=1,ncol)
if (outfile /= 6) close(outfile)
return
! open failed
901 write(psb_err_unit,*) 'mm_vet_write: could not open file ',&
& outfile,' for output'
info = -1
return
end subroutine mm_ivet2_write
subroutine mm_ivet1_write(b, header, info, iunit, filename)
use psb_base_mod
implicit none
integer(psb_ipk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
integer(psb_ipk_) :: nrow, ncol, i,root, np, me, ircode, j, outfile
character(len=80) :: frmtv
info = psb_success_
if (present(filename)) then
if (filename == '-') then
outfile=6
else
if (present(iunit)) then
outfile=iunit
else
outfile=99
endif
open(outfile,file=filename, err=901, action='WRITE')
endif
else
if (present(iunit)) then
outfile=iunit
else
outfile=6
endif
endif
write(outfile,'(a)') '%%MatrixMarket matrix array real general'
write(outfile,'(a)') '% '//trim(header)
write(outfile,'(a)') '% '
nrow = size(b,1)
ncol = 1
write(outfile,*) nrow,ncol
write(frmtv,'(a,i0,a)') '(',ncol,'(i14,1x))'
do i=1,size(b,1)
write(outfile,frmtv) b(i)
end do
if (outfile /= 6) close(outfile)
return
! open failed
901 write(psb_err_unit,*) 'mm_vet_write: could not open file ',&
& outfile,' for output'
info = -1
return
end subroutine mm_ivet1_write

37
util/psb_mmio_mod.F90
Unescape Escape View File

@ -107,6 +107,22 @@ module psb_mmio_mod
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet2_read
subroutine mm_ivet_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet_read
subroutine mm_ivet2_read(b, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), allocatable, intent(out) :: b(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet2_read
end interface
@ -192,13 +208,32 @@ module psb_mmio_mod
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_zvet1_write
subroutine mm_ivet2_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: b(:,:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet2_write
subroutine mm_ivet1_write(b, header, info, iunit, filename)
import :: psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: b(:)
character(len=*), intent(in) :: header
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
end subroutine mm_ivet1_write
end interface
#if ! defined(HAVE_BUGGY_GENERICS)
interface mm_vet_write
procedure mm_svet1_write, mm_dvet1_write, mm_cvet1_write,&
& mm_zvet1_write, mm_svet2_write, mm_dvet2_write, &
& mm_cvet2_write, mm_zvet2_write
& mm_cvet2_write, mm_zvet2_write, &
& mm_ivet1_write, mm_ivet2_write
end interface
#endif

Write Preview
Loading…
Cancel
Save