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

Implement clip_diag for LX

Browse Source
merge-paraggr
Salvatore Filippone 5 years ago
parent ece66421bf
commit 634c2e0aa5
8 changed files with 568 additions and 468 deletions
Show Stats Download Patch File Download Diff File

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

@ -370,6 +370,9 @@ module psb_c_mat_mod
generic, public :: cp_from => cp_from_b generic, public :: cp_from => cp_from_b
procedure, pass(a) :: cp_to_b => psb_lc_cp_to procedure, pass(a) :: cp_to_b => psb_lc_cp_to
generic, public :: cp_to => cp_to_b generic, public :: cp_to => cp_to_b
procedure, pass(a) :: clip_d_ip => psb_lc_clip_d_ip
procedure, pass(a) :: clip_d => psb_lc_clip_d
generic, public :: clip_diag => clip_d_ip, clip_d
procedure, pass(a) :: cscnv_np => psb_lc_cscnv procedure, pass(a) :: cscnv_np => psb_lc_cscnv
procedure, pass(a) :: cscnv_ip => psb_lc_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_lc_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_lc_cscnv_base procedure, pass(a) :: cscnv_base => psb_lc_cscnv_base
@ -1553,6 +1556,28 @@ module psb_c_mat_mod
end interface end interface
!
! Produce a version of the matrix with diagonal cut
! out; passes through a COO buffer.
!
interface
subroutine psb_lc_clip_d(a,b,info)
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type
class(psb_lcspmat_type), intent(in) :: a
class(psb_lcspmat_type), intent(inout) :: b
integer(psb_ipk_),intent(out) :: info
end subroutine psb_lc_clip_d
end interface
interface
subroutine psb_lc_clip_d_ip(a,info)
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type
class(psb_lcspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
end subroutine psb_lc_clip_d_ip
end interface
! !
! These four interfaces cut through the ! These four interfaces cut through the
! encapsulation between spmat_type and base_sparse_mat. ! encapsulation between spmat_type and base_sparse_mat.

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

@ -370,6 +370,9 @@ module psb_d_mat_mod
generic, public :: cp_from => cp_from_b generic, public :: cp_from => cp_from_b
procedure, pass(a) :: cp_to_b => psb_ld_cp_to procedure, pass(a) :: cp_to_b => psb_ld_cp_to
generic, public :: cp_to => cp_to_b generic, public :: cp_to => cp_to_b
procedure, pass(a) :: clip_d_ip => psb_ld_clip_d_ip
procedure, pass(a) :: clip_d => psb_ld_clip_d
generic, public :: clip_diag => clip_d_ip, clip_d
procedure, pass(a) :: cscnv_np => psb_ld_cscnv procedure, pass(a) :: cscnv_np => psb_ld_cscnv
procedure, pass(a) :: cscnv_ip => psb_ld_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_ld_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_ld_cscnv_base procedure, pass(a) :: cscnv_base => psb_ld_cscnv_base
@ -1553,6 +1556,28 @@ module psb_d_mat_mod
end interface end interface
!
! Produce a version of the matrix with diagonal cut
! out; passes through a COO buffer.
!
interface
subroutine psb_ld_clip_d(a,b,info)
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type
class(psb_ldspmat_type), intent(in) :: a
class(psb_ldspmat_type), intent(inout) :: b
integer(psb_ipk_),intent(out) :: info
end subroutine psb_ld_clip_d
end interface
interface
subroutine psb_ld_clip_d_ip(a,info)
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type
class(psb_ldspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
end subroutine psb_ld_clip_d_ip
end interface
! !
! These four interfaces cut through the ! These four interfaces cut through the
! encapsulation between spmat_type and base_sparse_mat. ! encapsulation between spmat_type and base_sparse_mat.

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

@ -370,6 +370,9 @@ module psb_s_mat_mod
generic, public :: cp_from => cp_from_b generic, public :: cp_from => cp_from_b
procedure, pass(a) :: cp_to_b => psb_ls_cp_to procedure, pass(a) :: cp_to_b => psb_ls_cp_to
generic, public :: cp_to => cp_to_b generic, public :: cp_to => cp_to_b
procedure, pass(a) :: clip_d_ip => psb_ls_clip_d_ip
procedure, pass(a) :: clip_d => psb_ls_clip_d
generic, public :: clip_diag => clip_d_ip, clip_d
procedure, pass(a) :: cscnv_np => psb_ls_cscnv procedure, pass(a) :: cscnv_np => psb_ls_cscnv
procedure, pass(a) :: cscnv_ip => psb_ls_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_ls_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_ls_cscnv_base procedure, pass(a) :: cscnv_base => psb_ls_cscnv_base
@ -1553,6 +1556,28 @@ module psb_s_mat_mod
end interface end interface
!
! Produce a version of the matrix with diagonal cut
! out; passes through a COO buffer.
!
interface
subroutine psb_ls_clip_d(a,b,info)
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type
class(psb_lsspmat_type), intent(in) :: a
class(psb_lsspmat_type), intent(inout) :: b
integer(psb_ipk_),intent(out) :: info
end subroutine psb_ls_clip_d
end interface
interface
subroutine psb_ls_clip_d_ip(a,info)
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type
class(psb_lsspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
end subroutine psb_ls_clip_d_ip
end interface
! !
! These four interfaces cut through the ! These four interfaces cut through the
! encapsulation between spmat_type and base_sparse_mat. ! encapsulation between spmat_type and base_sparse_mat.

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

@ -370,6 +370,9 @@ module psb_z_mat_mod
generic, public :: cp_from => cp_from_b generic, public :: cp_from => cp_from_b
procedure, pass(a) :: cp_to_b => psb_lz_cp_to procedure, pass(a) :: cp_to_b => psb_lz_cp_to
generic, public :: cp_to => cp_to_b generic, public :: cp_to => cp_to_b
procedure, pass(a) :: clip_d_ip => psb_lz_clip_d_ip
procedure, pass(a) :: clip_d => psb_lz_clip_d
generic, public :: clip_diag => clip_d_ip, clip_d
procedure, pass(a) :: cscnv_np => psb_lz_cscnv procedure, pass(a) :: cscnv_np => psb_lz_cscnv
procedure, pass(a) :: cscnv_ip => psb_lz_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_lz_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_lz_cscnv_base procedure, pass(a) :: cscnv_base => psb_lz_cscnv_base
@ -1553,6 +1556,28 @@ module psb_z_mat_mod
end interface end interface
!
! Produce a version of the matrix with diagonal cut
! out; passes through a COO buffer.
!
interface
subroutine psb_lz_clip_d(a,b,info)
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type
class(psb_lzspmat_type), intent(in) :: a
class(psb_lzspmat_type), intent(inout) :: b
integer(psb_ipk_),intent(out) :: info
end subroutine psb_lz_clip_d
end interface
interface
subroutine psb_lz_clip_d_ip(a,info)
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type
class(psb_lzspmat_type), intent(inout) :: a
integer(psb_ipk_),intent(out) :: info
end subroutine psb_lz_clip_d_ip
end interface
! !
! These four interfaces cut through the ! These four interfaces cut through the
! encapsulation between spmat_type and base_sparse_mat. ! encapsulation between spmat_type and base_sparse_mat.

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

@ -3933,123 +3933,123 @@ end subroutine psb_lc_cscnv_base
!!$subroutine psb_lc_clip_d(a,b,info) subroutine psb_lc_clip_d(a,b,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_c_base_mat_mod use psb_c_base_mat_mod
!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d
!!$ implicit none implicit none
!!$
!!$ class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(in) :: a
!!$ class(psb_lcspmat_type), intent(inout) :: b class(psb_lcspmat_type), intent(inout) :: b
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo type(psb_lc_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call b%mv_from(acoo) call b%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_lc_clip_d end subroutine psb_lc_clip_d
!!$
!!$
!!$
!!$subroutine psb_lc_clip_d_ip(a,info) subroutine psb_lc_clip_d_ip(a,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_c_base_mat_mod use psb_c_base_mat_mod
!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d_ip use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d_ip
!!$ implicit none implicit none
!!$
!!$ class(psb_lcspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: a
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo type(psb_lc_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call a%mv_from(acoo) call a%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_lc_clip_d_ip end subroutine psb_lc_clip_d_ip
!!$
subroutine psb_lc_mv_from(a,b) subroutine psb_lc_mv_from(a,b)
use psb_error_mod use psb_error_mod

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

@ -3933,123 +3933,123 @@ end subroutine psb_ld_cscnv_base
!!$subroutine psb_ld_clip_d(a,b,info) subroutine psb_ld_clip_d(a,b,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_d_base_mat_mod use psb_d_base_mat_mod
!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d
!!$ implicit none implicit none
!!$
!!$ class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(in) :: a
!!$ class(psb_ldspmat_type), intent(inout) :: b class(psb_ldspmat_type), intent(inout) :: b
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo type(psb_ld_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call b%mv_from(acoo) call b%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_ld_clip_d end subroutine psb_ld_clip_d
!!$
!!$
!!$
!!$subroutine psb_ld_clip_d_ip(a,info) subroutine psb_ld_clip_d_ip(a,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_d_base_mat_mod use psb_d_base_mat_mod
!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d_ip use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d_ip
!!$ implicit none implicit none
!!$
!!$ class(psb_ldspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: a
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo type(psb_ld_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call a%mv_from(acoo) call a%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_ld_clip_d_ip end subroutine psb_ld_clip_d_ip
!!$
subroutine psb_ld_mv_from(a,b) subroutine psb_ld_mv_from(a,b)
use psb_error_mod use psb_error_mod

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

@ -3933,123 +3933,123 @@ end subroutine psb_ls_cscnv_base
!!$subroutine psb_ls_clip_d(a,b,info) subroutine psb_ls_clip_d(a,b,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_s_base_mat_mod use psb_s_base_mat_mod
!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d
!!$ implicit none implicit none
!!$
!!$ class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(in) :: a
!!$ class(psb_lsspmat_type), intent(inout) :: b class(psb_lsspmat_type), intent(inout) :: b
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo type(psb_ls_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call b%mv_from(acoo) call b%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_ls_clip_d end subroutine psb_ls_clip_d
!!$
!!$
!!$
!!$subroutine psb_ls_clip_d_ip(a,info) subroutine psb_ls_clip_d_ip(a,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_s_base_mat_mod use psb_s_base_mat_mod
!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d_ip use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d_ip
!!$ implicit none implicit none
!!$
!!$ class(psb_lsspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: a
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo type(psb_ls_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call a%mv_from(acoo) call a%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_ls_clip_d_ip end subroutine psb_ls_clip_d_ip
!!$
subroutine psb_ls_mv_from(a,b) subroutine psb_ls_mv_from(a,b)
use psb_error_mod use psb_error_mod

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

@ -3933,123 +3933,123 @@ end subroutine psb_lz_cscnv_base
!!$subroutine psb_lz_clip_d(a,b,info) subroutine psb_lz_clip_d(a,b,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_z_base_mat_mod use psb_z_base_mat_mod
!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d
!!$ implicit none implicit none
!!$
!!$ class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(in) :: a
!!$ class(psb_lzspmat_type), intent(inout) :: b class(psb_lzspmat_type), intent(inout) :: b
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo type(psb_lz_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call b%mv_from(acoo) call b%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_lz_clip_d end subroutine psb_lz_clip_d
!!$
!!$
!!$
!!$subroutine psb_lz_clip_d_ip(a,info) subroutine psb_lz_clip_d_ip(a,info)
!!$ ! Output is always in COO format ! Output is always in COO format
!!$ use psb_error_mod use psb_error_mod
!!$ use psb_const_mod use psb_const_mod
!!$ use psb_z_base_mat_mod use psb_z_base_mat_mod
!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d_ip use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d_ip
!!$ implicit none implicit none
!!$
!!$ class(psb_lzspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: a
!!$ integer(psb_ipk_),intent(out) :: info integer(psb_ipk_),intent(out) :: info
!!$
!!$ integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
!!$ character(len=20) :: name='clip_diag' character(len=20) :: name='clip_diag'
!!$ logical, parameter :: debug=.false. logical, parameter :: debug=.false.
!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo type(psb_lz_coo_sparse_mat), allocatable :: acoo
!!$ integer(psb_lpk_) :: i, j, nz integer(psb_lpk_) :: i, j, nz
!!$
!!$ info = psb_success_ info = psb_success_
!!$ call psb_erractionsave(err_act) call psb_erractionsave(err_act)
!!$ if (a%is_null()) then if (a%is_null()) then
!!$ info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ allocate(acoo,stat=info) allocate(acoo,stat=info)
!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info)
!!$ if (info /= psb_success_) then if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name) call psb_errpush(info,name)
!!$ goto 9999 goto 9999
!!$ endif endif
!!$
!!$ nz = acoo%get_nzeros() nz = acoo%get_nzeros()
!!$ j = 0 j = 0
!!$ do i=1, nz do i=1, nz
!!$ if (acoo%ia(i) /= acoo%ja(i)) then if (acoo%ia(i) /= acoo%ja(i)) then
!!$ j = j + 1 j = j + 1
!!$ acoo%ia(j) = acoo%ia(i) acoo%ia(j) = acoo%ia(i)
!!$ acoo%ja(j) = acoo%ja(i) acoo%ja(j) = acoo%ja(i)
!!$ acoo%val(j) = acoo%val(i) acoo%val(j) = acoo%val(i)
!!$ end if end if
!!$ end do end do
!!$ call acoo%set_nzeros(j) call acoo%set_nzeros(j)
!!$ call acoo%trim() call acoo%trim()
!!$ call a%mv_from(acoo) call a%mv_from(acoo)
!!$
!!$ call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
!!$ return return
!!$
!!$
!!$9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
!!$
!!$ return return
!!$
!!$end subroutine psb_lz_clip_d_ip end subroutine psb_lz_clip_d_ip
!!$
subroutine psb_lz_mv_from(a,b) subroutine psb_lz_mv_from(a,b)
use psb_error_mod use psb_error_mod

Write Preview
Loading…
Cancel
Save