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

Take out GTL arg from CSPUT.

Browse Source
scr-persistent-collective
Salvatore Filippone 6 years ago
parent cd355ea1f0
commit cd8ae65c85
36 changed files with 1668 additions and 3976 deletions
Show Stats Download Patch File Download Diff File

18
base/modules/serial/psb_c_base_mat_mod.f90
Unescape Escape View File

@ -455,25 +455,23 @@ module psb_c_base_mat_mod
!! !!
! !
interface interface
subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_base_csput_a end subroutine psb_c_base_csput_a
end interface end interface
interface interface
subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: a
class(psb_c_base_vect_type), intent(inout) :: val class(psb_c_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_base_csput_v end subroutine psb_c_base_csput_v
end interface end interface
@ -1875,14 +1873,13 @@ module psb_c_base_mat_mod
!! !!
! !
interface interface
subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_coo_csput_a end subroutine psb_c_coo_csput_a
end interface end interface
@ -2137,25 +2134,23 @@ module psb_c_base_mat_mod
!! !!
! !
interface interface
subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_base_csput_a end subroutine psb_lc_base_csput_a
end interface end interface
interface interface
subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: a
class(psb_c_base_vect_type), intent(inout) :: val class(psb_c_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_base_csput_v end subroutine psb_lc_base_csput_v
end interface end interface
@ -3345,14 +3340,13 @@ module psb_c_base_mat_mod
!! !!
! !
interface interface
subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_coo_csput_a end subroutine psb_lc_coo_csput_a
end interface end interface

6
base/modules/serial/psb_c_csc_mat_mod.f90
Unescape Escape View File

@ -335,14 +335,13 @@ module psb_c_csc_mat_mod
!> \memberof psb_c_csc_sparse_mat !> \memberof psb_c_csc_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_csput_a !! \see psb_c_base_mat_mod::psb_c_base_csput_a
interface interface
subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_csc_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csc_csput_a end subroutine psb_c_csc_csput_a
end interface end interface
@ -727,14 +726,13 @@ module psb_c_csc_mat_mod
!> \memberof psb_lc_csc_sparse_mat !> \memberof psb_lc_csc_sparse_mat
!! \see psb_lc_base_mat_mod::psb_lc_base_csput_a !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a
interface interface
subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_csc_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csc_csput_a end subroutine psb_lc_csc_csput_a
end interface end interface

6
base/modules/serial/psb_c_csr_mat_mod.f90
Unescape Escape View File

@ -372,14 +372,13 @@ module psb_c_csr_mat_mod
!> \memberof psb_c_csr_sparse_mat !> \memberof psb_c_csr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_csput_a !! \see psb_c_base_mat_mod::psb_c_base_csput_a
interface interface
subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_csr_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csr_csput_a end subroutine psb_c_csr_csput_a
end interface end interface
@ -890,14 +889,13 @@ module psb_c_csr_mat_mod
!> \memberof psb_lc_csr_sparse_mat !> \memberof psb_lc_csr_sparse_mat
!! \see psb_lc_base_mat_mod::psb_lc_base_csput_a !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a
interface interface
subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_csr_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csr_csput_a end subroutine psb_lc_csr_csput_a
end interface end interface

12
base/modules/serial/psb_c_mat_mod.F90
Unescape Escape View File

@ -598,19 +598,18 @@ module psb_c_mat_mod
end interface end interface
interface interface
subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csput_a end subroutine psb_c_csput_a
end interface end interface
interface interface
subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_c_vect_mod, only : psb_c_vect_type use psb_c_vect_mod, only : psb_c_vect_type
use psb_i_vect_mod, only : psb_i_vect_type use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_lpk_, psb_cspmat_type import :: psb_ipk_, psb_lpk_, psb_cspmat_type
@ -619,7 +618,6 @@ module psb_c_mat_mod
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csput_v end subroutine psb_c_csput_v
end interface end interface
@ -1306,19 +1304,18 @@ module psb_c_mat_mod
end interface end interface
interface interface
subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_
class(psb_lcspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csput_a end subroutine psb_lc_csput_a
end interface end interface
interface interface
subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_c_vect_mod, only : psb_c_vect_type use psb_c_vect_mod, only : psb_c_vect_type
use psb_l_vect_mod, only : psb_l_vect_type use psb_l_vect_mod, only : psb_l_vect_type
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type import :: psb_ipk_, psb_lpk_, psb_lcspmat_type
@ -1327,7 +1324,6 @@ module psb_c_mat_mod
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csput_v end subroutine psb_lc_csput_v
end interface end interface

18
base/modules/serial/psb_d_base_mat_mod.f90
Unescape Escape View File

@ -455,25 +455,23 @@ module psb_d_base_mat_mod
!! !!
! !
interface interface
subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_base_csput_a end subroutine psb_d_base_csput_a
end interface end interface
interface interface
subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: a
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_base_csput_v end subroutine psb_d_base_csput_v
end interface end interface
@ -1875,14 +1873,13 @@ module psb_d_base_mat_mod
!! !!
! !
interface interface
subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_coo_csput_a end subroutine psb_d_coo_csput_a
end interface end interface
@ -2137,25 +2134,23 @@ module psb_d_base_mat_mod
!! !!
! !
interface interface
subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_base_csput_a end subroutine psb_ld_base_csput_a
end interface end interface
interface interface
subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: a
class(psb_d_base_vect_type), intent(inout) :: val class(psb_d_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_base_csput_v end subroutine psb_ld_base_csput_v
end interface end interface
@ -3345,14 +3340,13 @@ module psb_d_base_mat_mod
!! !!
! !
interface interface
subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_coo_csput_a end subroutine psb_ld_coo_csput_a
end interface end interface

6
base/modules/serial/psb_d_csc_mat_mod.f90
Unescape Escape View File

@ -335,14 +335,13 @@ module psb_d_csc_mat_mod
!> \memberof psb_d_csc_sparse_mat !> \memberof psb_d_csc_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_csput_a !! \see psb_d_base_mat_mod::psb_d_base_csput_a
interface interface
subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_csc_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csc_csput_a end subroutine psb_d_csc_csput_a
end interface end interface
@ -727,14 +726,13 @@ module psb_d_csc_mat_mod
!> \memberof psb_ld_csc_sparse_mat !> \memberof psb_ld_csc_sparse_mat
!! \see psb_ld_base_mat_mod::psb_ld_base_csput_a !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a
interface interface
subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_csc_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csc_csput_a end subroutine psb_ld_csc_csput_a
end interface end interface

6
base/modules/serial/psb_d_csr_mat_mod.f90
Unescape Escape View File

@ -372,14 +372,13 @@ module psb_d_csr_mat_mod
!> \memberof psb_d_csr_sparse_mat !> \memberof psb_d_csr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_csput_a !! \see psb_d_base_mat_mod::psb_d_base_csput_a
interface interface
subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csr_csput_a end subroutine psb_d_csr_csput_a
end interface end interface
@ -890,14 +889,13 @@ module psb_d_csr_mat_mod
!> \memberof psb_ld_csr_sparse_mat !> \memberof psb_ld_csr_sparse_mat
!! \see psb_ld_base_mat_mod::psb_ld_base_csput_a !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a
interface interface
subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csr_csput_a end subroutine psb_ld_csr_csput_a
end interface end interface

12
base/modules/serial/psb_d_mat_mod.F90
Unescape Escape View File

@ -598,19 +598,18 @@ module psb_d_mat_mod
end interface end interface
interface interface
subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csput_a end subroutine psb_d_csput_a
end interface end interface
interface interface
subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_d_vect_mod, only : psb_d_vect_type use psb_d_vect_mod, only : psb_d_vect_type
use psb_i_vect_mod, only : psb_i_vect_type use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_lpk_, psb_dspmat_type import :: psb_ipk_, psb_lpk_, psb_dspmat_type
@ -619,7 +618,6 @@ module psb_d_mat_mod
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csput_v end subroutine psb_d_csput_v
end interface end interface
@ -1306,19 +1304,18 @@ module psb_d_mat_mod
end interface end interface
interface interface
subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_
class(psb_ldspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csput_a end subroutine psb_ld_csput_a
end interface end interface
interface interface
subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_d_vect_mod, only : psb_d_vect_type use psb_d_vect_mod, only : psb_d_vect_type
use psb_l_vect_mod, only : psb_l_vect_type use psb_l_vect_mod, only : psb_l_vect_type
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type import :: psb_ipk_, psb_lpk_, psb_ldspmat_type
@ -1327,7 +1324,6 @@ module psb_d_mat_mod
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csput_v end subroutine psb_ld_csput_v
end interface end interface

18
base/modules/serial/psb_s_base_mat_mod.f90
Unescape Escape View File

@ -455,25 +455,23 @@ module psb_s_base_mat_mod
!! !!
! !
interface interface
subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_base_csput_a end subroutine psb_s_base_csput_a
end interface end interface
interface interface
subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: a
class(psb_s_base_vect_type), intent(inout) :: val class(psb_s_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_base_csput_v end subroutine psb_s_base_csput_v
end interface end interface
@ -1875,14 +1873,13 @@ module psb_s_base_mat_mod
!! !!
! !
interface interface
subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_coo_csput_a end subroutine psb_s_coo_csput_a
end interface end interface
@ -2137,25 +2134,23 @@ module psb_s_base_mat_mod
!! !!
! !
interface interface
subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_base_csput_a end subroutine psb_ls_base_csput_a
end interface end interface
interface interface
subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: a
class(psb_s_base_vect_type), intent(inout) :: val class(psb_s_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_base_csput_v end subroutine psb_ls_base_csput_v
end interface end interface
@ -3345,14 +3340,13 @@ module psb_s_base_mat_mod
!! !!
! !
interface interface
subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_coo_csput_a end subroutine psb_ls_coo_csput_a
end interface end interface

6
base/modules/serial/psb_s_csc_mat_mod.f90
Unescape Escape View File

@ -335,14 +335,13 @@ module psb_s_csc_mat_mod
!> \memberof psb_s_csc_sparse_mat !> \memberof psb_s_csc_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_csput_a !! \see psb_s_base_mat_mod::psb_s_base_csput_a
interface interface
subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_csc_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csc_csput_a end subroutine psb_s_csc_csput_a
end interface end interface
@ -727,14 +726,13 @@ module psb_s_csc_mat_mod
!> \memberof psb_ls_csc_sparse_mat !> \memberof psb_ls_csc_sparse_mat
!! \see psb_ls_base_mat_mod::psb_ls_base_csput_a !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a
interface interface
subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_csc_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csc_csput_a end subroutine psb_ls_csc_csput_a
end interface end interface

6
base/modules/serial/psb_s_csr_mat_mod.f90
Unescape Escape View File

@ -372,14 +372,13 @@ module psb_s_csr_mat_mod
!> \memberof psb_s_csr_sparse_mat !> \memberof psb_s_csr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_csput_a !! \see psb_s_base_mat_mod::psb_s_base_csput_a
interface interface
subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_csr_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csr_csput_a end subroutine psb_s_csr_csput_a
end interface end interface
@ -890,14 +889,13 @@ module psb_s_csr_mat_mod
!> \memberof psb_ls_csr_sparse_mat !> \memberof psb_ls_csr_sparse_mat
!! \see psb_ls_base_mat_mod::psb_ls_base_csput_a !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a
interface interface
subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_csr_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csr_csput_a end subroutine psb_ls_csr_csput_a
end interface end interface

12
base/modules/serial/psb_s_mat_mod.F90
Unescape Escape View File

@ -598,19 +598,18 @@ module psb_s_mat_mod
end interface end interface
interface interface
subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csput_a end subroutine psb_s_csput_a
end interface end interface
interface interface
subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_s_vect_mod, only : psb_s_vect_type use psb_s_vect_mod, only : psb_s_vect_type
use psb_i_vect_mod, only : psb_i_vect_type use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_lpk_, psb_sspmat_type import :: psb_ipk_, psb_lpk_, psb_sspmat_type
@ -619,7 +618,6 @@ module psb_s_mat_mod
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csput_v end subroutine psb_s_csput_v
end interface end interface
@ -1306,19 +1304,18 @@ module psb_s_mat_mod
end interface end interface
interface interface
subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_
class(psb_lsspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csput_a end subroutine psb_ls_csput_a
end interface end interface
interface interface
subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_s_vect_mod, only : psb_s_vect_type use psb_s_vect_mod, only : psb_s_vect_type
use psb_l_vect_mod, only : psb_l_vect_type use psb_l_vect_mod, only : psb_l_vect_type
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type import :: psb_ipk_, psb_lpk_, psb_lsspmat_type
@ -1327,7 +1324,6 @@ module psb_s_mat_mod
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csput_v end subroutine psb_ls_csput_v
end interface end interface

18
base/modules/serial/psb_z_base_mat_mod.f90
Unescape Escape View File

@ -455,25 +455,23 @@ module psb_z_base_mat_mod
!! !!
! !
interface interface
subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_base_csput_a end subroutine psb_z_base_csput_a
end interface end interface
interface interface
subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: a
class(psb_z_base_vect_type), intent(inout) :: val class(psb_z_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_base_csput_v end subroutine psb_z_base_csput_v
end interface end interface
@ -1875,14 +1873,13 @@ module psb_z_base_mat_mod
!! !!
! !
interface interface
subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_coo_csput_a end subroutine psb_z_coo_csput_a
end interface end interface
@ -2137,25 +2134,23 @@ module psb_z_base_mat_mod
!! !!
! !
interface interface
subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_base_csput_a end subroutine psb_lz_base_csput_a
end interface end interface
interface interface
subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: a
class(psb_z_base_vect_type), intent(inout) :: val class(psb_z_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_base_csput_v end subroutine psb_lz_base_csput_v
end interface end interface
@ -3345,14 +3340,13 @@ module psb_z_base_mat_mod
!! !!
! !
interface interface
subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_coo_csput_a end subroutine psb_lz_coo_csput_a
end interface end interface

6
base/modules/serial/psb_z_csc_mat_mod.f90
Unescape Escape View File

@ -335,14 +335,13 @@ module psb_z_csc_mat_mod
!> \memberof psb_z_csc_sparse_mat !> \memberof psb_z_csc_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_csput_a !! \see psb_z_base_mat_mod::psb_z_base_csput_a
interface interface
subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_csc_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csc_csput_a end subroutine psb_z_csc_csput_a
end interface end interface
@ -727,14 +726,13 @@ module psb_z_csc_mat_mod
!> \memberof psb_lz_csc_sparse_mat !> \memberof psb_lz_csc_sparse_mat
!! \see psb_lz_base_mat_mod::psb_lz_base_csput_a !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a
interface interface
subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_csc_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csc_csput_a end subroutine psb_lz_csc_csput_a
end interface end interface

6
base/modules/serial/psb_z_csr_mat_mod.f90
Unescape Escape View File

@ -372,14 +372,13 @@ module psb_z_csr_mat_mod
!> \memberof psb_z_csr_sparse_mat !> \memberof psb_z_csr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_csput_a !! \see psb_z_base_mat_mod::psb_z_base_csput_a
interface interface
subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_csr_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csr_csput_a end subroutine psb_z_csr_csput_a
end interface end interface
@ -890,14 +889,13 @@ module psb_z_csr_mat_mod
!> \memberof psb_lz_csr_sparse_mat !> \memberof psb_lz_csr_sparse_mat
!! \see psb_lz_base_mat_mod::psb_lz_base_csput_a !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a
interface interface
subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import import
class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_csr_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax & imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csr_csput_a end subroutine psb_lz_csr_csput_a
end interface end interface

12
base/modules/serial/psb_z_mat_mod.F90
Unescape Escape View File

@ -598,19 +598,18 @@ module psb_z_mat_mod
end interface end interface
interface interface
subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csput_a end subroutine psb_z_csput_a
end interface end interface
interface interface
subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_z_vect_mod, only : psb_z_vect_type use psb_z_vect_mod, only : psb_z_vect_type
use psb_i_vect_mod, only : psb_i_vect_type use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_lpk_, psb_zspmat_type import :: psb_ipk_, psb_lpk_, psb_zspmat_type
@ -619,7 +618,6 @@ module psb_z_mat_mod
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csput_v end subroutine psb_z_csput_v
end interface end interface
@ -1306,19 +1304,18 @@ module psb_z_mat_mod
end interface end interface
interface interface
subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_
class(psb_lzspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csput_a end subroutine psb_lz_csput_a
end interface end interface
interface interface
subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_z_vect_mod, only : psb_z_vect_type use psb_z_vect_mod, only : psb_z_vect_type
use psb_l_vect_mod, only : psb_l_vect_type use psb_l_vect_mod, only : psb_l_vect_type
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type import :: psb_ipk_, psb_lpk_, psb_lzspmat_type
@ -1327,7 +1324,6 @@ module psb_z_mat_mod
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csput_v end subroutine psb_lz_csput_v
end interface end interface

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

@ -326,7 +326,7 @@ subroutine psb_c_base_clean_zeros(a, info)
end subroutine psb_c_base_clean_zeros end subroutine psb_c_base_clean_zeros
subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_a use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_a
implicit none implicit none
@ -334,7 +334,6 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -351,7 +350,7 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_c_base_csput_a end subroutine psb_c_base_csput_a
subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_v use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_v
use psb_c_base_vect_mod use psb_c_base_vect_mod
@ -361,7 +360,6 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout integer(psb_ipk_) :: err_act, nzin, nzout
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -377,7 +375,7 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -2625,7 +2623,7 @@ subroutine psb_lc_base_clean_zeros(a, info)
end subroutine psb_lc_base_clean_zeros end subroutine psb_lc_base_clean_zeros
subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a
implicit none implicit none
@ -2633,7 +2631,6 @@ subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -2650,7 +2647,7 @@ subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_lc_base_csput_a end subroutine psb_lc_base_csput_a
subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v
use psb_c_base_vect_mod use psb_c_base_vect_mod
@ -2660,7 +2657,6 @@ subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout integer(psb_lpk_) :: nzin, nzout
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2677,7 +2673,7 @@ subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -2515,7 +2515,7 @@ contains
end subroutine psb_c_coo_csgetrow end subroutine psb_c_coo_csgetrow
subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -2526,7 +2526,6 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2579,7 +2578,7 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -2589,7 +2588,7 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call c_coo_srch_upd(nz,ia,ja,val,a,& call c_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2619,7 +2618,7 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -2628,46 +2627,25 @@ contains
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
complex(psb_spk_), intent(inout) :: aspk(:) complex(psb_spk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:) integer(psb_ipk_) :: i,ir,ic
integer(psb_ipk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine c_coo_srch_upd(nz,ia,ja,val,a,& subroutine c_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,nnz,dupl,ng, nr & i1,i2,nc,nnz,dupl,nr
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_coo_srch_upd' character(len=20) :: name='c_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,nnz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,nnz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,nnz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,nnz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine c_coo_srch_upd end subroutine c_coo_srch_upd
@ -5521,7 +5398,7 @@ contains
end subroutine psb_lc_coo_csgetrow end subroutine psb_lc_coo_csgetrow
subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -5532,7 +5409,6 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -5586,7 +5462,7 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -5596,7 +5472,7 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call lc_coo_srch_upd(nz,ia,ja,val,a,& call lc_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -5626,7 +5502,7 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -5635,46 +5511,25 @@ contains
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
complex(psb_spk_), intent(inout) :: aspk(:) complex(psb_spk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:) integer(psb_lpk_) :: i,ir,ic
integer(psb_lpk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine lc_coo_srch_upd(nz,ia,ja,val,a,& subroutine lc_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nnz,dupl,ng, nr & i1,i2,nnz,dupl, nr
integer(psb_ipk_) :: debug_level, debug_unit, innz, nc integer(psb_ipk_) :: debug_level, debug_unit, innz, nc
character(len=20) :: name='lc_coo_srch_upd' character(len=20) :: name='lc_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
innz = nnz innz = nnz
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,innz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,innz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,innz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,innz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine lc_coo_srch_upd end subroutine lc_coo_srch_upd

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

@ -1880,7 +1880,7 @@ end subroutine psb_c_csc_csgetrow
subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput_a use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput_a
@ -1890,8 +1890,6 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
@ -1941,7 +1939,7 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_c_csc_srch_upd(nz,ia,ja,val,a,& call psb_c_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -1973,7 +1971,7 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_c_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_c_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_csc_srch_upd' character(len=20) :: name='c_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr=i2-i1
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr=i2-i1 nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_c_csc_srch_upd end subroutine psb_c_csc_srch_upd
@ -3783,7 +3705,7 @@ end subroutine psb_lc_csc_csgetrow
subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csput_a use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csput_a
@ -3793,7 +3715,6 @@ subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5)
@ -3843,7 +3764,7 @@ subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_lc_csc_srch_upd(nz,ia,ja,val,a,& call psb_lc_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -3875,7 +3796,7 @@ subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_lc_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_lc_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit, inr integer(psb_ipk_) :: debug_level, debug_unit, inr
character(len=20) :: name='lc_csc_srch_upd' character(len=20) :: name='lc_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr = i2-i1
ic = gtl(ic) inr = nr
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr = i2-i1 nr = i2-i1
inr = nr inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_lc_csc_srch_upd end subroutine psb_lc_csc_srch_upd

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

@ -2490,7 +2490,7 @@ subroutine psb_c_csr_triu(a,u,info,&
end subroutine psb_c_csr_triu end subroutine psb_c_csr_triu
subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput_a use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput_a
@ -2500,8 +2500,6 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='c_csr_csput_a' character(len=20) :: name='c_csr_csput_a'
@ -2547,7 +2545,7 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_c_csr_srch_upd(nz,ia,ja,val,a,& call psb_c_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2579,7 +2577,7 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_c_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_c_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng & i1,i2,nr,nc,nnz,dupl
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='c_csr_srch_upd' character(len=20) :: name='c_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc=i2-i1 nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = val(i) a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_c_csr_srch_upd end subroutine psb_c_csr_srch_upd
@ -4661,7 +4584,7 @@ subroutine psb_lc_csr_triu(a,u,info,&
end subroutine psb_lc_csr_triu end subroutine psb_lc_csr_triu
subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csput_a use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csput_a
@ -4671,7 +4594,6 @@ subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -4719,7 +4641,7 @@ subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_lc_csr_srch_upd(nz,ia,ja,val,a,& call psb_lc_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -4751,7 +4673,7 @@ subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_lc_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_lc_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,ng & i1,i2,nr,nc,nnz
integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc
character(len=20) :: name='lc_csr_srch_upd' character(len=20) :: name='lc_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ir > 0).and.(ir <= nr)) then
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = a%irp(ir)
ir = gtl(ir) i2 = a%irp(ir+1)
ic = gtl(ic) nc=i2-i1
if ((ir > 0).and.(ir <= nr)) then inc = nc
i1 = a%irp(ir) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
i2 = a%irp(ir+1) if (ip>0) then
nc=i2-i1 a%val(i1+ip-1) = val(i)
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
inc = nc inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_lc_csr_srch_upd end subroutine psb_lc_csr_srch_upd

20
base/serial/impl/psb_c_mat_impl.F90
Unescape Escape View File

@ -661,7 +661,7 @@ end subroutine psb_c_trim
subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_c_mat_mod, psb_protect_name => psb_c_csput_a use psb_c_mat_mod, psb_protect_name => psb_c_csput_a
use psb_c_base_mat_mod use psb_c_base_mat_mod
use psb_error_mod use psb_error_mod
@ -670,7 +670,6 @@ subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -685,7 +684,7 @@ subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -698,7 +697,7 @@ subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_c_csput_a end subroutine psb_c_csput_a
subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_c_mat_mod, psb_protect_name => psb_c_csput_v use psb_c_mat_mod, psb_protect_name => psb_c_csput_v
use psb_c_base_mat_mod use psb_c_base_mat_mod
use psb_c_vect_mod, only : psb_c_vect_type use psb_c_vect_mod, only : psb_c_vect_type
@ -710,7 +709,6 @@ subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -725,7 +723,7 @@ subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -3190,7 +3188,7 @@ end subroutine psb_lc_trim
subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_c_mat_mod, psb_protect_name => psb_lc_csput_a use psb_c_mat_mod, psb_protect_name => psb_lc_csput_a
use psb_c_base_mat_mod use psb_c_base_mat_mod
use psb_error_mod use psb_error_mod
@ -3199,7 +3197,6 @@ subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -3214,7 +3211,7 @@ subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -3227,7 +3224,7 @@ subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_lc_csput_a end subroutine psb_lc_csput_a
subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_c_mat_mod, psb_protect_name => psb_lc_csput_v use psb_c_mat_mod, psb_protect_name => psb_lc_csput_v
use psb_c_base_mat_mod use psb_c_base_mat_mod
use psb_c_vect_mod, only : psb_c_vect_type use psb_c_vect_mod, only : psb_c_vect_type
@ -3239,7 +3236,6 @@ subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -3254,7 +3250,7 @@ subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -326,7 +326,7 @@ subroutine psb_d_base_clean_zeros(a, info)
end subroutine psb_d_base_clean_zeros end subroutine psb_d_base_clean_zeros
subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_a use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_a
implicit none implicit none
@ -334,7 +334,6 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -351,7 +350,7 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_d_base_csput_a end subroutine psb_d_base_csput_a
subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_v use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_v
use psb_d_base_vect_mod use psb_d_base_vect_mod
@ -361,7 +360,6 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout integer(psb_ipk_) :: err_act, nzin, nzout
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -377,7 +375,7 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -2625,7 +2623,7 @@ subroutine psb_ld_base_clean_zeros(a, info)
end subroutine psb_ld_base_clean_zeros end subroutine psb_ld_base_clean_zeros
subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a
implicit none implicit none
@ -2633,7 +2631,6 @@ subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -2650,7 +2647,7 @@ subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_ld_base_csput_a end subroutine psb_ld_base_csput_a
subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v
use psb_d_base_vect_mod use psb_d_base_vect_mod
@ -2660,7 +2657,6 @@ subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout integer(psb_lpk_) :: nzin, nzout
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2677,7 +2673,7 @@ subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -2515,7 +2515,7 @@ contains
end subroutine psb_d_coo_csgetrow end subroutine psb_d_coo_csgetrow
subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -2526,7 +2526,6 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2579,7 +2578,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -2589,7 +2588,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call d_coo_srch_upd(nz,ia,ja,val,a,& call d_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2619,7 +2618,7 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -2628,46 +2627,25 @@ contains
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
real(psb_dpk_), intent(inout) :: aspk(:) real(psb_dpk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:) integer(psb_ipk_) :: i,ir,ic
integer(psb_ipk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine d_coo_srch_upd(nz,ia,ja,val,a,& subroutine d_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,nnz,dupl,ng, nr & i1,i2,nc,nnz,dupl,nr
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_coo_srch_upd' character(len=20) :: name='d_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,nnz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,nnz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,nnz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,nnz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine d_coo_srch_upd end subroutine d_coo_srch_upd
@ -5521,7 +5398,7 @@ contains
end subroutine psb_ld_coo_csgetrow end subroutine psb_ld_coo_csgetrow
subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -5532,7 +5409,6 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -5586,7 +5462,7 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -5596,7 +5472,7 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call ld_coo_srch_upd(nz,ia,ja,val,a,& call ld_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -5626,7 +5502,7 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -5635,46 +5511,25 @@ contains
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
real(psb_dpk_), intent(inout) :: aspk(:) real(psb_dpk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:) integer(psb_lpk_) :: i,ir,ic
integer(psb_lpk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine ld_coo_srch_upd(nz,ia,ja,val,a,& subroutine ld_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nnz,dupl,ng, nr & i1,i2,nnz,dupl, nr
integer(psb_ipk_) :: debug_level, debug_unit, innz, nc integer(psb_ipk_) :: debug_level, debug_unit, innz, nc
character(len=20) :: name='ld_coo_srch_upd' character(len=20) :: name='ld_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
innz = nnz innz = nnz
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,innz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,innz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,innz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,innz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine ld_coo_srch_upd end subroutine ld_coo_srch_upd

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

@ -1880,7 +1880,7 @@ end subroutine psb_d_csc_csgetrow
subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput_a use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput_a
@ -1890,8 +1890,6 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
@ -1941,7 +1939,7 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_d_csc_srch_upd(nz,ia,ja,val,a,& call psb_d_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -1973,7 +1971,7 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_d_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_d_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_csc_srch_upd' character(len=20) :: name='d_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr=i2-i1
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr=i2-i1 nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_d_csc_srch_upd end subroutine psb_d_csc_srch_upd
@ -3783,7 +3705,7 @@ end subroutine psb_ld_csc_csgetrow
subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csput_a use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csput_a
@ -3793,7 +3715,6 @@ subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5)
@ -3843,7 +3764,7 @@ subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_ld_csc_srch_upd(nz,ia,ja,val,a,& call psb_ld_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -3875,7 +3796,7 @@ subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_ld_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_ld_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit, inr integer(psb_ipk_) :: debug_level, debug_unit, inr
character(len=20) :: name='ld_csc_srch_upd' character(len=20) :: name='ld_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr = i2-i1
ic = gtl(ic) inr = nr
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr = i2-i1 nr = i2-i1
inr = nr inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_ld_csc_srch_upd end subroutine psb_ld_csc_srch_upd

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

@ -2490,7 +2490,7 @@ subroutine psb_d_csr_triu(a,u,info,&
end subroutine psb_d_csr_triu end subroutine psb_d_csr_triu
subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput_a use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput_a
@ -2500,8 +2500,6 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='d_csr_csput_a' character(len=20) :: name='d_csr_csput_a'
@ -2547,7 +2545,7 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_d_csr_srch_upd(nz,ia,ja,val,a,& call psb_d_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2579,7 +2577,7 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_d_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_d_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng & i1,i2,nr,nc,nnz,dupl
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='d_csr_srch_upd' character(len=20) :: name='d_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc=i2-i1 nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = val(i) a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_d_csr_srch_upd end subroutine psb_d_csr_srch_upd
@ -4661,7 +4584,7 @@ subroutine psb_ld_csr_triu(a,u,info,&
end subroutine psb_ld_csr_triu end subroutine psb_ld_csr_triu
subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csput_a use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csput_a
@ -4671,7 +4594,6 @@ subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -4719,7 +4641,7 @@ subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_ld_csr_srch_upd(nz,ia,ja,val,a,& call psb_ld_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -4751,7 +4673,7 @@ subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_ld_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_ld_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,ng & i1,i2,nr,nc,nnz
integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc
character(len=20) :: name='ld_csr_srch_upd' character(len=20) :: name='ld_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ir > 0).and.(ir <= nr)) then
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = a%irp(ir)
ir = gtl(ir) i2 = a%irp(ir+1)
ic = gtl(ic) nc=i2-i1
if ((ir > 0).and.(ir <= nr)) then inc = nc
i1 = a%irp(ir) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
i2 = a%irp(ir+1) if (ip>0) then
nc=i2-i1 a%val(i1+ip-1) = val(i)
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
inc = nc inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_ld_csr_srch_upd end subroutine psb_ld_csr_srch_upd

20
base/serial/impl/psb_d_mat_impl.F90
Unescape Escape View File

@ -661,7 +661,7 @@ end subroutine psb_d_trim
subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_d_mat_mod, psb_protect_name => psb_d_csput_a use psb_d_mat_mod, psb_protect_name => psb_d_csput_a
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_error_mod use psb_error_mod
@ -670,7 +670,6 @@ subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -685,7 +684,7 @@ subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -698,7 +697,7 @@ subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_d_csput_a end subroutine psb_d_csput_a
subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_d_mat_mod, psb_protect_name => psb_d_csput_v use psb_d_mat_mod, psb_protect_name => psb_d_csput_v
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_vect_mod, only : psb_d_vect_type use psb_d_vect_mod, only : psb_d_vect_type
@ -710,7 +709,6 @@ subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -725,7 +723,7 @@ subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -3190,7 +3188,7 @@ end subroutine psb_ld_trim
subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_d_mat_mod, psb_protect_name => psb_ld_csput_a use psb_d_mat_mod, psb_protect_name => psb_ld_csput_a
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_error_mod use psb_error_mod
@ -3199,7 +3197,6 @@ subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -3214,7 +3211,7 @@ subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -3227,7 +3224,7 @@ subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_ld_csput_a end subroutine psb_ld_csput_a
subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_d_mat_mod, psb_protect_name => psb_ld_csput_v use psb_d_mat_mod, psb_protect_name => psb_ld_csput_v
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_vect_mod, only : psb_d_vect_type use psb_d_vect_mod, only : psb_d_vect_type
@ -3239,7 +3236,6 @@ subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -3254,7 +3250,7 @@ subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -326,7 +326,7 @@ subroutine psb_s_base_clean_zeros(a, info)
end subroutine psb_s_base_clean_zeros end subroutine psb_s_base_clean_zeros
subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_a use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_a
implicit none implicit none
@ -334,7 +334,6 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -351,7 +350,7 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_s_base_csput_a end subroutine psb_s_base_csput_a
subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_v use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_v
use psb_s_base_vect_mod use psb_s_base_vect_mod
@ -361,7 +360,6 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout integer(psb_ipk_) :: err_act, nzin, nzout
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -377,7 +375,7 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -2625,7 +2623,7 @@ subroutine psb_ls_base_clean_zeros(a, info)
end subroutine psb_ls_base_clean_zeros end subroutine psb_ls_base_clean_zeros
subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a
implicit none implicit none
@ -2633,7 +2631,6 @@ subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -2650,7 +2647,7 @@ subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_ls_base_csput_a end subroutine psb_ls_base_csput_a
subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v
use psb_s_base_vect_mod use psb_s_base_vect_mod
@ -2660,7 +2657,6 @@ subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout integer(psb_lpk_) :: nzin, nzout
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2677,7 +2673,7 @@ subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -2515,7 +2515,7 @@ contains
end subroutine psb_s_coo_csgetrow end subroutine psb_s_coo_csgetrow
subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -2526,7 +2526,6 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2579,7 +2578,7 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -2589,7 +2588,7 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call s_coo_srch_upd(nz,ia,ja,val,a,& call s_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2619,7 +2618,7 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -2628,46 +2627,25 @@ contains
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
real(psb_spk_), intent(inout) :: aspk(:) real(psb_spk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:) integer(psb_ipk_) :: i,ir,ic
integer(psb_ipk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine s_coo_srch_upd(nz,ia,ja,val,a,& subroutine s_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,nnz,dupl,ng, nr & i1,i2,nc,nnz,dupl,nr
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_coo_srch_upd' character(len=20) :: name='s_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,nnz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,nnz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,nnz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,nnz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine s_coo_srch_upd end subroutine s_coo_srch_upd
@ -5521,7 +5398,7 @@ contains
end subroutine psb_ls_coo_csgetrow end subroutine psb_ls_coo_csgetrow
subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -5532,7 +5409,6 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -5586,7 +5462,7 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -5596,7 +5472,7 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call ls_coo_srch_upd(nz,ia,ja,val,a,& call ls_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -5626,7 +5502,7 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -5635,46 +5511,25 @@ contains
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
real(psb_spk_), intent(inout) :: aspk(:) real(psb_spk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:) integer(psb_lpk_) :: i,ir,ic
integer(psb_lpk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine ls_coo_srch_upd(nz,ia,ja,val,a,& subroutine ls_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nnz,dupl,ng, nr & i1,i2,nnz,dupl, nr
integer(psb_ipk_) :: debug_level, debug_unit, innz, nc integer(psb_ipk_) :: debug_level, debug_unit, innz, nc
character(len=20) :: name='ls_coo_srch_upd' character(len=20) :: name='ls_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
innz = nnz innz = nnz
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,innz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,innz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,innz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,innz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine ls_coo_srch_upd end subroutine ls_coo_srch_upd

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

@ -1880,7 +1880,7 @@ end subroutine psb_s_csc_csgetrow
subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput_a use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput_a
@ -1890,8 +1890,6 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
@ -1941,7 +1939,7 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_s_csc_srch_upd(nz,ia,ja,val,a,& call psb_s_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -1973,7 +1971,7 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_s_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_s_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_csc_srch_upd' character(len=20) :: name='s_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr=i2-i1
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr=i2-i1 nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_s_csc_srch_upd end subroutine psb_s_csc_srch_upd
@ -3783,7 +3705,7 @@ end subroutine psb_ls_csc_csgetrow
subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csput_a use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csput_a
@ -3793,7 +3715,6 @@ subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5)
@ -3843,7 +3764,7 @@ subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_ls_csc_srch_upd(nz,ia,ja,val,a,& call psb_ls_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -3875,7 +3796,7 @@ subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_ls_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_ls_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit, inr integer(psb_ipk_) :: debug_level, debug_unit, inr
character(len=20) :: name='ls_csc_srch_upd' character(len=20) :: name='ls_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr = i2-i1
ic = gtl(ic) inr = nr
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr = i2-i1 nr = i2-i1
inr = nr inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_ls_csc_srch_upd end subroutine psb_ls_csc_srch_upd

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

@ -2490,7 +2490,7 @@ subroutine psb_s_csr_triu(a,u,info,&
end subroutine psb_s_csr_triu end subroutine psb_s_csr_triu
subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput_a use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput_a
@ -2500,8 +2500,6 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='s_csr_csput_a' character(len=20) :: name='s_csr_csput_a'
@ -2547,7 +2545,7 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_s_csr_srch_upd(nz,ia,ja,val,a,& call psb_s_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2579,7 +2577,7 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_s_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_s_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng & i1,i2,nr,nc,nnz,dupl
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='s_csr_srch_upd' character(len=20) :: name='s_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc=i2-i1 nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = val(i) a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_s_csr_srch_upd end subroutine psb_s_csr_srch_upd
@ -4661,7 +4584,7 @@ subroutine psb_ls_csr_triu(a,u,info,&
end subroutine psb_ls_csr_triu end subroutine psb_ls_csr_triu
subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csput_a use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csput_a
@ -4671,7 +4594,6 @@ subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -4719,7 +4641,7 @@ subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_ls_csr_srch_upd(nz,ia,ja,val,a,& call psb_ls_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -4751,7 +4673,7 @@ subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_ls_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_ls_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,ng & i1,i2,nr,nc,nnz
integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc
character(len=20) :: name='ls_csr_srch_upd' character(len=20) :: name='ls_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ir > 0).and.(ir <= nr)) then
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = a%irp(ir)
ir = gtl(ir) i2 = a%irp(ir+1)
ic = gtl(ic) nc=i2-i1
if ((ir > 0).and.(ir <= nr)) then inc = nc
i1 = a%irp(ir) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
i2 = a%irp(ir+1) if (ip>0) then
nc=i2-i1 a%val(i1+ip-1) = val(i)
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
inc = nc inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_ls_csr_srch_upd end subroutine psb_ls_csr_srch_upd

20
base/serial/impl/psb_s_mat_impl.F90
Unescape Escape View File

@ -661,7 +661,7 @@ end subroutine psb_s_trim
subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_s_mat_mod, psb_protect_name => psb_s_csput_a use psb_s_mat_mod, psb_protect_name => psb_s_csput_a
use psb_s_base_mat_mod use psb_s_base_mat_mod
use psb_error_mod use psb_error_mod
@ -670,7 +670,6 @@ subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -685,7 +684,7 @@ subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -698,7 +697,7 @@ subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_s_csput_a end subroutine psb_s_csput_a
subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_s_mat_mod, psb_protect_name => psb_s_csput_v use psb_s_mat_mod, psb_protect_name => psb_s_csput_v
use psb_s_base_mat_mod use psb_s_base_mat_mod
use psb_s_vect_mod, only : psb_s_vect_type use psb_s_vect_mod, only : psb_s_vect_type
@ -710,7 +709,6 @@ subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -725,7 +723,7 @@ subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -3190,7 +3188,7 @@ end subroutine psb_ls_trim
subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_s_mat_mod, psb_protect_name => psb_ls_csput_a use psb_s_mat_mod, psb_protect_name => psb_ls_csput_a
use psb_s_base_mat_mod use psb_s_base_mat_mod
use psb_error_mod use psb_error_mod
@ -3199,7 +3197,6 @@ subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -3214,7 +3211,7 @@ subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -3227,7 +3224,7 @@ subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_ls_csput_a end subroutine psb_ls_csput_a
subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_s_mat_mod, psb_protect_name => psb_ls_csput_v use psb_s_mat_mod, psb_protect_name => psb_ls_csput_v
use psb_s_base_mat_mod use psb_s_base_mat_mod
use psb_s_vect_mod, only : psb_s_vect_type use psb_s_vect_mod, only : psb_s_vect_type
@ -3239,7 +3236,6 @@ subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -3254,7 +3250,7 @@ subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -326,7 +326,7 @@ subroutine psb_z_base_clean_zeros(a, info)
end subroutine psb_z_base_clean_zeros end subroutine psb_z_base_clean_zeros
subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_a use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_a
implicit none implicit none
@ -334,7 +334,6 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -351,7 +350,7 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_z_base_csput_a end subroutine psb_z_base_csput_a
subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_v use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_v
use psb_z_base_vect_mod use psb_z_base_vect_mod
@ -361,7 +360,6 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_i_base_vect_type), intent(inout) :: ia, ja class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout integer(psb_ipk_) :: err_act, nzin, nzout
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -377,7 +375,7 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -2625,7 +2623,7 @@ subroutine psb_lz_base_clean_zeros(a, info)
end subroutine psb_lz_base_clean_zeros end subroutine psb_lz_base_clean_zeros
subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a
implicit none implicit none
@ -2633,7 +2631,6 @@ subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput' character(len=20) :: name='csput'
@ -2650,7 +2647,7 @@ subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_lz_base_csput_a end subroutine psb_lz_base_csput_a
subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v
use psb_z_base_vect_mod use psb_z_base_vect_mod
@ -2660,7 +2657,6 @@ subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
class(psb_l_base_vect_type), intent(inout) :: ia, ja class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout integer(psb_lpk_) :: nzin, nzout
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2677,7 +2673,7 @@ subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (val%is_dev()) call val%sync() if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync() if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync() if (ja%is_dev()) call ja%sync()
call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

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

@ -2515,7 +2515,7 @@ contains
end subroutine psb_z_coo_csgetrow end subroutine psb_z_coo_csgetrow
subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -2526,7 +2526,6 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -2579,7 +2578,7 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -2589,7 +2588,7 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call z_coo_srch_upd(nz,ia,ja,val,a,& call z_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2619,7 +2618,7 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -2628,46 +2627,25 @@ contains
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
complex(psb_dpk_), intent(inout) :: aspk(:) complex(psb_dpk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:) integer(psb_ipk_) :: i,ir,ic
integer(psb_ipk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine z_coo_srch_upd(nz,ia,ja,val,a,& subroutine z_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,nnz,dupl,ng, nr & i1,i2,nc,nnz,dupl,nr
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_coo_srch_upd' character(len=20) :: name='z_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,nnz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,nnz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,nnz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,nnz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,nnz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine z_coo_srch_upd end subroutine z_coo_srch_upd
@ -5521,7 +5398,7 @@ contains
end subroutine psb_lz_coo_csgetrow end subroutine psb_lz_coo_csgetrow
subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
@ -5532,7 +5409,6 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -5586,7 +5462,7 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if end if
call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
call a%set_nzeros(nza) call a%set_nzeros(nza)
call a%set_sorted(.false.) call a%set_sorted(.false.)
@ -5596,7 +5472,7 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (a%is_dev()) call a%sync() if (a%is_dev()) call a%sync()
call lz_coo_srch_upd(nz,ia,ja,val,a,& call lz_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -5626,7 +5502,7 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
implicit none implicit none
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz
@ -5635,46 +5511,25 @@ contains
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
complex(psb_dpk_), intent(inout) :: aspk(:) complex(psb_dpk_), intent(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:) integer(psb_lpk_) :: i,ir,ic
integer(psb_lpk_) :: i,ir,ic,ng
info = psb_success_ info = psb_success_
if (present(gtl)) then do i=1, nz
ng = size(gtl) ir = ia(i)
ic = ja(i)
do i=1, nz if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
ir = ia(i) nza = nza + 1
ic = ja(i) ia1(nza) = ir
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then ia2(nza) = ic
ir = gtl(ir) aspk(nza) = val(i)
ic = gtl(ic) end if
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then end do
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end if
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
ia1(nza) = ir
ia2(nza) = ic
aspk(nza) = val(i)
end if
end do
end if
end subroutine psb_inner_ins end subroutine psb_inner_ins
subroutine lz_coo_srch_upd(nz,ia,ja,val,a,& subroutine lz_coo_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nnz,dupl,ng, nr & i1,i2,nnz,dupl, nr
integer(psb_ipk_) :: debug_level, debug_unit, innz, nc integer(psb_ipk_) :: debug_level, debug_unit, innz, nc
character(len=20) :: name='lz_coo_srch_upd' character(len=20) :: name='lz_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
innz = nnz innz = nnz
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_) do i=1, nz
! Overwrite. ir = ia(i)
! Cannot test for error, should have been caught earlier. ic = ja(i)
do i=1, nz if ((ir > 0).and.(ir <= nr)) then
ir = ia(i)
ic = ja(i) if (ir /= ilr) then
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = psb_bsrch(ir,innz,a%ia)
ir = gtl(ir) i2 = i1
if ((ir > 0).and.(ir <= nr)) then do
ic = gtl(ic) if (i2+1 > nnz) exit
if (ir /= ilr) then if (a%ia(i2+1) /= a%ia(i2)) exit
i1 = psb_bsrch(ir,innz,a%ia) i2 = i2 + 1
i2 = i1 end do
do do
if (i2+1 > nnz) exit if (i1-1 < 1) exit
if (a%ia(i2+1) /= a%ia(i2)) exit if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i2 + 1 i1 = i1 - 1
end do end do
do ilr = ir
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
else else
info = max(info,1) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
case(psb_dupl_add_) ip = psb_ssrch(ic,nc,a%ja(i1:i2))
! Add if (ip>0) then
do i=1, nz a%val(i1+ip-1) = val(i)
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else case(psb_dupl_add_)
! Add
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
select case(dupl) if (ir /= ilr) then
case(psb_dupl_ovwrt_,psb_dupl_err_) i1 = psb_bsrch(ir,innz,a%ia)
! Overwrite. i2 = i1
! Cannot test for error, should have been caught earlier. do
do i=1, nz if (i2+1 > nnz) exit
ir = ia(i) if (a%ia(i2+1) /= a%ia(i2)) exit
ic = ja(i) i2 = i2 + 1
if ((ir > 0).and.(ir <= nr)) then end do
do
if (ir /= ilr) then if (i1-1 < 1) exit
i1 = psb_bsrch(ir,innz,a%ia) if (a%ia(i1-1) /= a%ia(i1)) exit
i2 = i1 i1 = i1 - 1
do end do
if (i2+1 > nnz) exit ilr = ir
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) i1 = 1
i2 = 1
end if end if
end do nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
case(psb_dupl_add_) if (ip>0) then
! Add a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if (ir /= ilr) then
i1 = psb_bsrch(ir,innz,a%ia)
i2 = i1
do
if (i2+1 > nnz) exit
if (a%ia(i2+1) /= a%ia(i2)) exit
i2 = i2 + 1
end do
do
if (i1-1 < 1) exit
if (a%ia(i1-1) /= a%ia(i1)) exit
i1 = i1 - 1
end do
ilr = ir
else
i1 = 1
i2 = 1
end if
nc = i2-i1+1
ip = psb_ssrch(ic,nc,a%ja(i1:i2))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine lz_coo_srch_upd end subroutine lz_coo_srch_upd

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

@ -1880,7 +1880,7 @@ end subroutine psb_z_csc_csgetrow
subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput_a use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput_a
@ -1890,8 +1890,6 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
@ -1941,7 +1939,7 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_z_csc_srch_upd(nz,ia,ja,val,a,& call psb_z_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -1973,7 +1971,7 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_z_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_z_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_csc_srch_upd' character(len=20) :: name='z_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr=i2-i1
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr=i2-i1 nr=i2-i1
ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,nr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_z_csc_srch_upd end subroutine psb_z_csc_srch_upd
@ -3783,7 +3705,7 @@ end subroutine psb_lz_csc_csgetrow
subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csput_a use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csput_a
@ -3793,7 +3715,6 @@ subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5)
@ -3843,7 +3764,7 @@ subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_lz_csc_srch_upd(nz,ia,ja,val,a,& call psb_lz_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -3875,7 +3796,7 @@ subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_lz_csc_srch_upd(nz,ia,ja,val,a,& subroutine psb_lz_csc_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng, nar, nac & i1,i2,nr,nc,nnz,dupl,nar, nac
integer(psb_ipk_) :: debug_level, debug_unit, inr integer(psb_ipk_) :: debug_level, debug_unit, inr
character(len=20) :: name='lz_csc_srch_upd' character(len=20) :: name='lz_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows() nar = a%get_nrows()
nac = a%get_ncols() nac = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ic > 0).and.(ic <= nac)) then
ic = ja(i) i1 = a%icp(ic)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i2 = a%icp(ic+1)
ir = gtl(ir) nr = i2-i1
ic = gtl(ic) inr = nr
if ((ic > 0).and.(ic <= nac)) then ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
i1 = a%icp(ic) if (ip>0) then
i2 = a%icp(ic+1) a%val(i1+ip-1) = val(i)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic)
i2 = a%icp(ic+1)
nr = i2-i1
inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if end if
else
info = max(info,2)
end if
end do end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ic > 0).and.(ic <= nac)) then if ((ic > 0).and.(ic <= nac)) then
i1 = a%icp(ic) i1 = a%icp(ic)
i2 = a%icp(ic+1) i2 = a%icp(ic+1)
nr = i2-i1 nr = i2-i1
inr = nr inr = nr
ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) ip = psb_bsrch(ir,inr,a%ia(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_lz_csc_srch_upd end subroutine psb_lz_csc_srch_upd

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

@ -2490,7 +2490,7 @@ subroutine psb_z_csr_triu(a,u,info,&
end subroutine psb_z_csr_triu end subroutine psb_z_csr_triu
subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput_a use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput_a
@ -2500,8 +2500,6 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='z_csr_csput_a' character(len=20) :: name='z_csr_csput_a'
@ -2547,7 +2545,7 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_z_csr_srch_upd(nz,ia,ja,val,a,& call psb_z_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -2579,7 +2577,7 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_z_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_z_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_ipk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,dupl,ng & i1,i2,nr,nc,nnz,dupl
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name='z_csr_srch_upd' character(len=20) :: name='z_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc=i2-i1 nc=i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = val(i) a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_z_csr_srch_upd end subroutine psb_z_csr_srch_upd
@ -4661,7 +4584,7 @@ subroutine psb_lz_csr_triu(a,u,info,&
end subroutine psb_lz_csr_triu end subroutine psb_lz_csr_triu
subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csput_a use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csput_a
@ -4671,7 +4594,6 @@ subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
@ -4719,7 +4641,7 @@ subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
else if (a%is_upd()) then else if (a%is_upd()) then
call psb_lz_csr_srch_upd(nz,ia,ja,val,a,& call psb_lz_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
if (info < 0) then if (info < 0) then
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -4751,7 +4673,7 @@ subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine psb_lz_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_lz_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nr,nc,nnz,ng & i1,i2,nr,nc,nnz
integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc
character(len=20) :: name='lz_csr_srch_upd' character(len=20) :: name='lz_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows() nr = a%get_nrows()
nc = a%get_ncols() nc = a%get_ncols()
if (present(gtl)) then select case(dupl)
ng = size(gtl) case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
select case(dupl) ! Cannot test for error, should have been caught earlier.
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite. ilr = -1
! Cannot test for error, should have been caught earlier. ilc = -1
do i=1, nz
ilr = -1 ir = ia(i)
ilc = -1 ic = ja(i)
do i=1, nz
ir = ia(i) if ((ir > 0).and.(ir <= nr)) then
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then i1 = a%irp(ir)
ir = gtl(ir) i2 = a%irp(ir+1)
ic = gtl(ic) nc=i2-i1
if ((ir > 0).and.(ir <= nr)) then inc = nc
i1 = a%irp(ir) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
i2 = a%irp(ir+1) if (ip>0) then
nc=i2-i1 a%val(i1+ip-1) = val(i)
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else
info = max(info,1)
end if
end do
case(psb_dupl_add_)
! Add
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
else else
info = max(info,1) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
else
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then
a%val(i1+ip-1) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
case(psb_dupl_add_) case(psb_dupl_add_)
! Add ! Add
ilr = -1 ilr = -1
ilc = -1 ilc = -1
do i=1, nz do i=1, nz
ir = ia(i) ir = ia(i)
ic = ja(i) ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir) i1 = a%irp(ir)
i2 = a%irp(ir+1) i2 = a%irp(ir+1)
nc = i2-i1 nc = i2-i1
inc = nc inc = nc
ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) ip = psb_bsrch(ic,inc,a%ja(i1:i2-1))
if (ip>0) then if (ip>0) then
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
else else
info = max(info,2) info = max(info,3)
end if end if
end do else
info = max(info,2)
case default end if
info = -3 end do
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end if case default
info = -3
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Duplicate handling: ',dupl
end select
end subroutine psb_lz_csr_srch_upd end subroutine psb_lz_csr_srch_upd

20
base/serial/impl/psb_z_mat_impl.F90
Unescape Escape View File

@ -661,7 +661,7 @@ end subroutine psb_z_trim
subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_z_mat_mod, psb_protect_name => psb_z_csput_a use psb_z_mat_mod, psb_protect_name => psb_z_csput_a
use psb_z_base_mat_mod use psb_z_base_mat_mod
use psb_error_mod use psb_error_mod
@ -670,7 +670,6 @@ subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -685,7 +684,7 @@ subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -698,7 +697,7 @@ subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_z_csput_a end subroutine psb_z_csput_a
subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_z_mat_mod, psb_protect_name => psb_z_csput_v use psb_z_mat_mod, psb_protect_name => psb_z_csput_v
use psb_z_base_mat_mod use psb_z_base_mat_mod
use psb_z_vect_mod, only : psb_z_vect_type use psb_z_vect_mod, only : psb_z_vect_type
@ -710,7 +709,6 @@ subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_i_vect_type), intent(inout) :: ia, ja type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -725,7 +723,7 @@ subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif
@ -3190,7 +3188,7 @@ end subroutine psb_lz_trim
subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_z_mat_mod, psb_protect_name => psb_lz_csput_a use psb_z_mat_mod, psb_protect_name => psb_lz_csput_a
use psb_z_base_mat_mod use psb_z_base_mat_mod
use psb_error_mod use psb_error_mod
@ -3199,7 +3197,6 @@ subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_a' character(len=20) :: name='csput_a'
@ -3214,7 +3211,7 @@ subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -3227,7 +3224,7 @@ subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end subroutine psb_lz_csput_a end subroutine psb_lz_csput_a
subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info)
use psb_z_mat_mod, psb_protect_name => psb_lz_csput_v use psb_z_mat_mod, psb_protect_name => psb_lz_csput_v
use psb_z_base_mat_mod use psb_z_base_mat_mod
use psb_z_vect_mod, only : psb_z_vect_type use psb_z_vect_mod, only : psb_z_vect_type
@ -3239,7 +3236,6 @@ subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
type(psb_l_vect_type), intent(inout) :: ia, ja type(psb_l_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v' character(len=20) :: name='csput_v'
@ -3254,7 +3250,7 @@ subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
endif endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else else
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
endif endif

Write Preview
Loading…
Cancel
Save