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
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
class(psb_c_base_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_base_csput_a
end 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
class(psb_c_base_sparse_mat), intent(inout) :: a
class(psb_c_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_base_csput_v
end interface
@ -1875,14 +1873,13 @@ module psb_c_base_mat_mod
!!
!
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
class(psb_c_coo_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_coo_csput_a
end interface
@ -2137,25 +2134,23 @@ module psb_c_base_mat_mod
!!
!
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
class(psb_lc_base_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_base_csput_a
end 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
class(psb_lc_base_sparse_mat), intent(inout) :: a
class(psb_c_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_base_csput_v
end interface
@ -3345,14 +3340,13 @@ module psb_c_base_mat_mod
!!
!
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
class(psb_lc_coo_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_coo_csput_a
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
!! \see psb_c_base_mat_mod::psb_c_base_csput_a
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
class(psb_c_csc_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csc_csput_a
end interface
@ -727,14 +726,13 @@ module psb_c_csc_mat_mod
!> \memberof psb_lc_csc_sparse_mat
!! \see psb_lc_base_mat_mod::psb_lc_base_csput_a
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
class(psb_lc_csc_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csc_csput_a
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
!! \see psb_c_base_mat_mod::psb_c_base_csput_a
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
class(psb_c_csr_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csr_csput_a
end interface
@ -890,14 +889,13 @@ module psb_c_csr_mat_mod
!> \memberof psb_lc_csr_sparse_mat
!! \see psb_lc_base_mat_mod::psb_lc_base_csput_a
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
class(psb_lc_csr_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csr_csput_a
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
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_
class(psb_cspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csput_a
end 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_i_vect_mod, only : psb_i_vect_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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csput_v
end interface
@ -1306,19 +1304,18 @@ module psb_c_mat_mod
end 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_
class(psb_lcspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csput_a
end 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_l_vect_mod, only : psb_l_vect_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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lc_csput_v
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
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
class(psb_d_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_base_csput_a
end 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
class(psb_d_base_sparse_mat), intent(inout) :: a
class(psb_d_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_base_csput_v
end interface
@ -1875,14 +1873,13 @@ module psb_d_base_mat_mod
!!
!
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
class(psb_d_coo_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_coo_csput_a
end interface
@ -2137,25 +2134,23 @@ module psb_d_base_mat_mod
!!
!
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
class(psb_ld_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_base_csput_a
end 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
class(psb_ld_base_sparse_mat), intent(inout) :: a
class(psb_d_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_base_csput_v
end interface
@ -3345,14 +3340,13 @@ module psb_d_base_mat_mod
!!
!
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
class(psb_ld_coo_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_coo_csput_a
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
!! \see psb_d_base_mat_mod::psb_d_base_csput_a
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
class(psb_d_csc_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csc_csput_a
end interface
@ -727,14 +726,13 @@ module psb_d_csc_mat_mod
!> \memberof psb_ld_csc_sparse_mat
!! \see psb_ld_base_mat_mod::psb_ld_base_csput_a
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
class(psb_ld_csc_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csc_csput_a
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
!! \see psb_d_base_mat_mod::psb_d_base_csput_a
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
class(psb_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csr_csput_a
end interface
@ -890,14 +889,13 @@ module psb_d_csr_mat_mod
!> \memberof psb_ld_csr_sparse_mat
!! \see psb_ld_base_mat_mod::psb_ld_base_csput_a
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
class(psb_ld_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csr_csput_a
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
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_
class(psb_dspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csput_a
end 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_i_vect_mod, only : psb_i_vect_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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csput_v
end interface
@ -1306,19 +1304,18 @@ module psb_d_mat_mod
end 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_
class(psb_ldspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csput_a
end 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_l_vect_mod, only : psb_l_vect_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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ld_csput_v
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
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
class(psb_s_base_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_base_csput_a
end 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
class(psb_s_base_sparse_mat), intent(inout) :: a
class(psb_s_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_base_csput_v
end interface
@ -1875,14 +1873,13 @@ module psb_s_base_mat_mod
!!
!
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
class(psb_s_coo_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_coo_csput_a
end interface
@ -2137,25 +2134,23 @@ module psb_s_base_mat_mod
!!
!
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
class(psb_ls_base_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_base_csput_a
end 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
class(psb_ls_base_sparse_mat), intent(inout) :: a
class(psb_s_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_base_csput_v
end interface
@ -3345,14 +3340,13 @@ module psb_s_base_mat_mod
!!
!
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
class(psb_ls_coo_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_coo_csput_a
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
!! \see psb_s_base_mat_mod::psb_s_base_csput_a
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
class(psb_s_csc_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csc_csput_a
end interface
@ -727,14 +726,13 @@ module psb_s_csc_mat_mod
!> \memberof psb_ls_csc_sparse_mat
!! \see psb_ls_base_mat_mod::psb_ls_base_csput_a
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
class(psb_ls_csc_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csc_csput_a
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
!! \see psb_s_base_mat_mod::psb_s_base_csput_a
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
class(psb_s_csr_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csr_csput_a
end interface
@ -890,14 +889,13 @@ module psb_s_csr_mat_mod
!> \memberof psb_ls_csr_sparse_mat
!! \see psb_ls_base_mat_mod::psb_ls_base_csput_a
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
class(psb_ls_csr_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csr_csput_a
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
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_
class(psb_sspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csput_a
end 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_i_vect_mod, only : psb_i_vect_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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csput_v
end interface
@ -1306,19 +1304,18 @@ module psb_s_mat_mod
end 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_
class(psb_lsspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csput_a
end 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_l_vect_mod, only : psb_l_vect_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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_ls_csput_v
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
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
class(psb_z_base_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_base_csput_a
end 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
class(psb_z_base_sparse_mat), intent(inout) :: a
class(psb_z_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_base_csput_v
end interface
@ -1875,14 +1873,13 @@ module psb_z_base_mat_mod
!!
!
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
class(psb_z_coo_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_coo_csput_a
end interface
@ -2137,25 +2134,23 @@ module psb_z_base_mat_mod
!!
!
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
class(psb_lz_base_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_base_csput_a
end 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
class(psb_lz_base_sparse_mat), intent(inout) :: a
class(psb_z_base_vect_type), intent(inout) :: val
class(psb_l_base_vect_type), intent(inout) :: ia, ja
integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_base_csput_v
end interface
@ -3345,14 +3340,13 @@ module psb_z_base_mat_mod
!!
!
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
class(psb_lz_coo_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_coo_csput_a
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
!! \see psb_z_base_mat_mod::psb_z_base_csput_a
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
class(psb_z_csc_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csc_csput_a
end interface
@ -727,14 +726,13 @@ module psb_z_csc_mat_mod
!> \memberof psb_lz_csc_sparse_mat
!! \see psb_lz_base_mat_mod::psb_lz_base_csput_a
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
class(psb_lz_csc_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csc_csput_a
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
!! \see psb_z_base_mat_mod::psb_z_base_csput_a
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
class(psb_z_csr_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csr_csput_a
end interface
@ -890,14 +889,13 @@ module psb_z_csr_mat_mod
!> \memberof psb_lz_csr_sparse_mat
!! \see psb_lz_base_mat_mod::psb_lz_base_csput_a
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
class(psb_lz_csr_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csr_csput_a
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
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_
class(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csput_a
end 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_i_vect_mod, only : psb_i_vect_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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csput_v
end interface
@ -1306,19 +1304,18 @@ module psb_z_mat_mod
end 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_
class(psb_lzspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csput_a
end 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_l_vect_mod, only : psb_l_vect_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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
end subroutine psb_lz_csput_v
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
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_c_base_mat_mod, psb_protect_name => psb_c_base_csput_a
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_c_base_mat_mod, psb_protect_name => psb_c_base_csput_v
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
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 (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else
info = psb_err_invalid_mat_state_
endif
@ -2625,7 +2623,7 @@ subroutine psb_lc_base_clean_zeros(a, info)
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_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout
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 (ia%is_dev()) call ia%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
info = psb_err_invalid_mat_state_
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
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_realloc_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic,ng
integer(psb_ipk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='c_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -5521,7 +5398,7 @@ contains
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_realloc_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic,ng
integer(psb_lpk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='lc_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows()
innz = nnz
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='c_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,2)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='lc_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
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,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
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)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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
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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='c_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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.
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)
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
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
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,2)
info = max(info,3)
end if
end do
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -4661,7 +4584,7 @@ subroutine psb_lc_csr_triu(a,u,info,&
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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='lc_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,1)
info = max(info,3)
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 ((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
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_base_mat_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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_base_mat_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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
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_d_base_mat_mod, psb_protect_name => psb_d_base_csput_a
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_d_base_mat_mod, psb_protect_name => psb_d_base_csput_v
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
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 (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else
info = psb_err_invalid_mat_state_
endif
@ -2625,7 +2623,7 @@ subroutine psb_ld_base_clean_zeros(a, info)
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_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout
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 (ia%is_dev()) call ia%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
info = psb_err_invalid_mat_state_
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
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_realloc_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic,ng
integer(psb_ipk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='d_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -5521,7 +5398,7 @@ contains
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_realloc_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic,ng
integer(psb_lpk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='ld_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows()
innz = nnz
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='d_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,2)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='ld_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
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,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
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)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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
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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='d_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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.
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)
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
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
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,2)
info = max(info,3)
end if
end do
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -4661,7 +4584,7 @@ subroutine psb_ld_csr_triu(a,u,info,&
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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='ld_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,1)
info = max(info,3)
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 ((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
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_base_mat_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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_base_mat_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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
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_s_base_mat_mod, psb_protect_name => psb_s_base_csput_a
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_s_base_mat_mod, psb_protect_name => psb_s_base_csput_v
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
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 (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else
info = psb_err_invalid_mat_state_
endif
@ -2625,7 +2623,7 @@ subroutine psb_ls_base_clean_zeros(a, info)
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_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout
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 (ia%is_dev()) call ia%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
info = psb_err_invalid_mat_state_
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
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_realloc_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic,ng
integer(psb_ipk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='s_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -5521,7 +5398,7 @@ contains
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_realloc_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic,ng
integer(psb_lpk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='ls_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows()
innz = nnz
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='s_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,2)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='ls_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
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,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
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)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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
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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='s_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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.
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)
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
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
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,2)
info = max(info,3)
end if
end do
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -4661,7 +4584,7 @@ subroutine psb_ls_csr_triu(a,u,info,&
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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='ls_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,1)
info = max(info,3)
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 ((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
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_base_mat_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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_base_mat_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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
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_z_base_mat_mod, psb_protect_name => psb_z_base_csput_a
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_z_base_mat_mod, psb_protect_name => psb_z_base_csput_v
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
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 (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info)
else
info = psb_err_invalid_mat_state_
endif
@ -2625,7 +2623,7 @@ subroutine psb_lz_base_clean_zeros(a, info)
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_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: nzin, nzout
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 (ia%is_dev()) call ia%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
info = psb_err_invalid_mat_state_
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
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_realloc_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: i,ir,ic,ng
integer(psb_ipk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -2679,9 +2657,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='z_coo_srch_upd'
@ -2703,188 +2680,88 @@ contains
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -5521,7 +5398,7 @@ contains
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_realloc_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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_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()
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
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
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
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(inout) :: aspk(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_lpk_) :: i,ir,ic,ng
integer(psb_lpk_) :: i,ir,ic
info = psb_success_
if (present(gtl)) then
ng = size(gtl)
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 >=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 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
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 subroutine psb_inner_ins
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_realloc_mod
@ -5686,9 +5541,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='lz_coo_srch_upd'
@ -5709,188 +5563,88 @@ contains
nr = a%get_nrows()
innz = nnz
if (present(gtl)) then
ng = size(gtl)
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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)
if ((ir > 0).and.(ir <= nr)) then
ic = gtl(ic)
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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
endif
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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
info = max(info,1)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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
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,1)
info = max(info,3)
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
info = max(info,2)
end if
end do
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)
case(psb_dupl_ovwrt_,psb_dupl_err_)
! Overwrite.
! Cannot test for error, should have been caught earlier.
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) = val(i)
else
info = max(info,3)
end if
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
info = max(info,2)
i1 = 1
i2 = 1
end if
end do
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -1986,9 +1984,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='z_csc_srch_upd'
@ -2009,138 +2006,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,2)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -3888,9 +3809,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='lz_csc_srch_upd'
@ -3911,138 +3831,63 @@ contains
nar = a%get_nrows()
nac = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = val(i)
else
info = max(info,3)
end if
else
info = max(info,2)
end if
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,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
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)
info = max(info,3)
end if
else
info = max(info,2)
end if
end do
end do
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,3)
end if
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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
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_realloc_mod
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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_realloc_mod
@ -2592,9 +2590,8 @@ contains
integer(psb_ipk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='z_csr_srch_upd'
@ -2615,136 +2612,62 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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.
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)
ilr = -1
ilc = -1
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= nr)) then
if ((ir > 0).and.(ir <= nr)) then
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
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
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,2)
info = max(info,3)
end if
end do
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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
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,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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
@ -4661,7 +4584,7 @@ subroutine psb_lz_csr_triu(a,u,info,&
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_realloc_mod
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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
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
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
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_realloc_mod
@ -4764,9 +4686,8 @@ contains
integer(psb_lpk_), intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
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
character(len=20) :: name='lz_csr_srch_upd'
@ -4787,138 +4708,63 @@ contains
nr = a%get_nrows()
nc = a%get_ncols()
if (present(gtl)) then
ng = size(gtl)
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 >=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) = 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
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,1)
info = max(info,3)
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 ((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
else
info = max(info,2)
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 > 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
case(psb_dupl_add_)
! Add
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) = a%val(i1+ip-1) + val(i)
else
info = max(info,2)
info = max(info,3)
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
info = max(info,2)
end if
end do
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

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_base_mat_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(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
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_base_mat_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(:)
integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
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
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_base_mat_mod
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
integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
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
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
info = psb_err_invalid_mat_state_
endif

Write Preview
Loading…
Cancel
Save