diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index 81e5f86a..44144bfe 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -370,6 +370,9 @@ module psb_c_mat_mod generic, public :: cp_from => cp_from_b procedure, pass(a) :: cp_to_b => psb_lc_cp_to 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_ip => psb_lc_cscnv_ip procedure, pass(a) :: cscnv_base => psb_lc_cscnv_base @@ -1553,6 +1556,28 @@ module psb_c_mat_mod 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 ! encapsulation between spmat_type and base_sparse_mat. diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index 9f4a5eef..7e89165f 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -370,6 +370,9 @@ module psb_d_mat_mod generic, public :: cp_from => cp_from_b procedure, pass(a) :: cp_to_b => psb_ld_cp_to 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_ip => psb_ld_cscnv_ip procedure, pass(a) :: cscnv_base => psb_ld_cscnv_base @@ -1553,6 +1556,28 @@ module psb_d_mat_mod 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 ! encapsulation between spmat_type and base_sparse_mat. diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 4701f9ea..248cc586 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -370,6 +370,9 @@ module psb_s_mat_mod generic, public :: cp_from => cp_from_b procedure, pass(a) :: cp_to_b => psb_ls_cp_to 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_ip => psb_ls_cscnv_ip procedure, pass(a) :: cscnv_base => psb_ls_cscnv_base @@ -1553,6 +1556,28 @@ module psb_s_mat_mod 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 ! encapsulation between spmat_type and base_sparse_mat. diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index 6f4803ee..6ed2cf57 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -370,6 +370,9 @@ module psb_z_mat_mod generic, public :: cp_from => cp_from_b procedure, pass(a) :: cp_to_b => psb_lz_cp_to 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_ip => psb_lz_cscnv_ip procedure, pass(a) :: cscnv_base => psb_lz_cscnv_base @@ -1553,6 +1556,28 @@ module psb_z_mat_mod 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 ! encapsulation between spmat_type and base_sparse_mat. diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 8e03a45b..5965f368 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -3933,123 +3933,123 @@ end subroutine psb_lc_cscnv_base -!!$subroutine psb_lc_clip_d(a,b,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_c_base_mat_mod -!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d -!!$ implicit none -!!$ -!!$ class(psb_lcspmat_type), intent(in) :: a -!!$ class(psb_lcspmat_type), intent(inout) :: b -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call b%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_lc_clip_d -!!$ -!!$ -!!$ -!!$subroutine psb_lc_clip_d_ip(a,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_c_base_mat_mod -!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d_ip -!!$ implicit none -!!$ -!!$ class(psb_lcspmat_type), intent(inout) :: a -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call a%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_lc_clip_d_ip -!!$ +subroutine psb_lc_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d + implicit none + + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_clip_d + + + +subroutine psb_lc_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d_ip + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_clip_d_ip + subroutine psb_lc_mv_from(a,b) use psb_error_mod diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 49d02097..abb70cd3 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -3933,123 +3933,123 @@ end subroutine psb_ld_cscnv_base -!!$subroutine psb_ld_clip_d(a,b,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_d_base_mat_mod -!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d -!!$ implicit none -!!$ -!!$ class(psb_ldspmat_type), intent(in) :: a -!!$ class(psb_ldspmat_type), intent(inout) :: b -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call b%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_ld_clip_d -!!$ -!!$ -!!$ -!!$subroutine psb_ld_clip_d_ip(a,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_d_base_mat_mod -!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d_ip -!!$ implicit none -!!$ -!!$ class(psb_ldspmat_type), intent(inout) :: a -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call a%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_ld_clip_d_ip -!!$ +subroutine psb_ld_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d + implicit none + + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_clip_d + + + +subroutine psb_ld_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d_ip + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_clip_d_ip + subroutine psb_ld_mv_from(a,b) use psb_error_mod diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index a94ce2ef..53292d01 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -3933,123 +3933,123 @@ end subroutine psb_ls_cscnv_base -!!$subroutine psb_ls_clip_d(a,b,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_s_base_mat_mod -!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d -!!$ implicit none -!!$ -!!$ class(psb_lsspmat_type), intent(in) :: a -!!$ class(psb_lsspmat_type), intent(inout) :: b -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call b%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_ls_clip_d -!!$ -!!$ -!!$ -!!$subroutine psb_ls_clip_d_ip(a,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_s_base_mat_mod -!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d_ip -!!$ implicit none -!!$ -!!$ class(psb_lsspmat_type), intent(inout) :: a -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call a%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_ls_clip_d_ip -!!$ +subroutine psb_ls_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d + implicit none + + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_clip_d + + + +subroutine psb_ls_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d_ip + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_clip_d_ip + subroutine psb_ls_mv_from(a,b) use psb_error_mod diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index ba193e47..f2af20f5 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -3933,123 +3933,123 @@ end subroutine psb_lz_cscnv_base -!!$subroutine psb_lz_clip_d(a,b,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_z_base_mat_mod -!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d -!!$ implicit none -!!$ -!!$ class(psb_lzspmat_type), intent(in) :: a -!!$ class(psb_lzspmat_type), intent(inout) :: b -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call b%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_lz_clip_d -!!$ -!!$ -!!$ -!!$subroutine psb_lz_clip_d_ip(a,info) -!!$ ! Output is always in COO format -!!$ use psb_error_mod -!!$ use psb_const_mod -!!$ use psb_z_base_mat_mod -!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d_ip -!!$ implicit none -!!$ -!!$ class(psb_lzspmat_type), intent(inout) :: a -!!$ integer(psb_ipk_),intent(out) :: info -!!$ -!!$ integer(psb_ipk_) :: err_act -!!$ character(len=20) :: name='clip_diag' -!!$ logical, parameter :: debug=.false. -!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo -!!$ integer(psb_lpk_) :: i, j, nz -!!$ -!!$ info = psb_success_ -!!$ call psb_erractionsave(err_act) -!!$ if (a%is_null()) then -!!$ info = psb_err_invalid_mat_state_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ allocate(acoo,stat=info) -!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ -!!$ nz = acoo%get_nzeros() -!!$ j = 0 -!!$ do i=1, nz -!!$ if (acoo%ia(i) /= acoo%ja(i)) then -!!$ j = j + 1 -!!$ acoo%ia(j) = acoo%ia(i) -!!$ acoo%ja(j) = acoo%ja(i) -!!$ acoo%val(j) = acoo%val(i) -!!$ end if -!!$ end do -!!$ call acoo%set_nzeros(j) -!!$ call acoo%trim() -!!$ call a%mv_from(acoo) -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$ -!!$9999 call psb_error_handler(err_act) -!!$ -!!$ return -!!$ -!!$end subroutine psb_lz_clip_d_ip -!!$ +subroutine psb_lz_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d + implicit none + + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_clip_d + + + +subroutine psb_lz_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d_ip + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: acoo + integer(psb_lpk_) :: i, j, nz + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_clip_d_ip + subroutine psb_lz_mv_from(a,b) use psb_error_mod