From 01f4f718de64aed98cac0cc0a26a2ae76101518f Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Tue, 14 Apr 2020 18:56:22 +0200 Subject: [PATCH] Corrected implementation of scale plus identity for sparse matrices --- base/modules/serial/psb_c_csc_mat_mod.f90 | 36 ++--- base/modules/serial/psb_c_csr_mat_mod.f90 | 18 +-- base/modules/serial/psb_d_csc_mat_mod.f90 | 36 ++--- base/modules/serial/psb_d_csr_mat_mod.f90 | 18 +-- base/modules/serial/psb_s_csc_mat_mod.f90 | 36 ++--- base/modules/serial/psb_s_csr_mat_mod.f90 | 18 +-- base/modules/serial/psb_z_csc_mat_mod.f90 | 36 ++--- base/modules/serial/psb_z_csr_mat_mod.f90 | 18 +-- base/serial/impl/psb_c_base_mat_impl.F90 | 64 +++++++-- base/serial/impl/psb_c_csc_impl.f90 | 168 +++++++++++----------- base/serial/impl/psb_c_csr_impl.f90 | 80 +++++------ base/serial/impl/psb_d_base_mat_impl.F90 | 64 +++++++-- base/serial/impl/psb_d_csc_impl.f90 | 168 +++++++++++----------- base/serial/impl/psb_d_csr_impl.f90 | 80 +++++------ base/serial/impl/psb_s_base_mat_impl.F90 | 64 +++++++-- base/serial/impl/psb_s_csc_impl.f90 | 168 +++++++++++----------- base/serial/impl/psb_s_csr_impl.f90 | 80 +++++------ base/serial/impl/psb_z_base_mat_impl.F90 | 64 +++++++-- base/serial/impl/psb_z_csc_impl.f90 | 168 +++++++++++----------- base/serial/impl/psb_z_csr_impl.f90 | 80 +++++------ 20 files changed, 820 insertions(+), 644 deletions(-) diff --git a/base/modules/serial/psb_c_csc_mat_mod.f90 b/base/modules/serial/psb_c_csc_mat_mod.f90 index 0a4db372..300052f3 100644 --- a/base/modules/serial/psb_c_csc_mat_mod.f90 +++ b/base/modules/serial/psb_c_csc_mat_mod.f90 @@ -71,7 +71,7 @@ module psb_c_csc_mat_mod procedure, pass(a) :: inner_cssv => psb_c_csc_cssv procedure, pass(a) :: scals => psb_c_csc_scals procedure, pass(a) :: scalv => psb_c_csc_scal - procedure, pass(a) :: scalpid => psb_c_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_c_csc_scalplusidentity procedure, pass(a) :: maxval => psb_c_csc_maxval procedure, pass(a) :: spnm1 => psb_c_csc_csnm1 procedure, pass(a) :: rowsum => psb_c_csc_rowsum @@ -128,7 +128,7 @@ module psb_c_csc_mat_mod procedure, pass(a) :: sizeof => lc_csc_sizeof procedure, pass(a) :: scals => psb_lc_csc_scals procedure, pass(a) :: scalv => psb_lc_csc_scal - procedure, pass(a) :: scalpid => psb_lc_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_lc_csc_scalplusidentity procedure, pass(a) :: maxval => psb_lc_csc_maxval procedure, pass(a) :: spnm1 => psb_lc_csc_csnm1 procedure, pass(a) :: rowsum => psb_lc_csc_rowsum @@ -565,14 +565,14 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scalplusidentity - interface - subroutine psb_c_csc_scalplusidentity(d,a,info) - import - class(psb_c_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_c_csc_scalplusidentity - end interface + ! interface + ! subroutine psb_c_csc_scalplusidentity(d,a,info) + ! import + ! class(psb_c_csc_sparse_mat), intent(inout) :: a + ! complex(psb_spk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_c_csc_scalplusidentity + ! end interface ! @@ -928,14 +928,14 @@ module psb_c_csc_mat_mod !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scalplusidentity - interface - subroutine psb_lc_csc_scalplusidentity(d,a,info) - import - class(psb_lc_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lc_csc_scalplusidentity - end interface +! interface +! subroutine psb_lc_csc_scalplusidentity(d,a,info) +! import +! class(psb_lc_csc_sparse_mat), intent(inout) :: a +! complex(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! end subroutine psb_lc_csc_scalplusidentity +! end interface contains diff --git a/base/modules/serial/psb_c_csr_mat_mod.f90 b/base/modules/serial/psb_c_csr_mat_mod.f90 index f2b2f65c..4f7d267d 100644 --- a/base/modules/serial/psb_c_csr_mat_mod.f90 +++ b/base/modules/serial/psb_c_csr_mat_mod.f90 @@ -73,7 +73,7 @@ module psb_c_csr_mat_mod procedure, pass(a) :: inner_cssv => psb_c_csr_cssv procedure, pass(a) :: scals => psb_c_csr_scals procedure, pass(a) :: scalv => psb_c_csr_scal - procedure, pass(a) :: scalpid => psb_c_csr_scalplusidentity +! procedure, pass(a) :: scalpid => psb_c_csr_scalplusidentity procedure, pass(a) :: maxval => psb_c_csr_maxval procedure, pass(a) :: spnmi => psb_c_csr_csnmi procedure, pass(a) :: rowsum => psb_c_csr_rowsum @@ -582,14 +582,14 @@ module psb_c_csr_mat_mod !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scalplusidentity - interface - subroutine psb_c_csr_scalplusidentity(d,a,info) - import - class(psb_c_csr_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_c_csr_scalplusidentity - end interface + ! interface + ! subroutine psb_c_csr_scalplusidentity(d,a,info) + ! import + ! class(psb_c_csr_sparse_mat), intent(inout) :: a + ! complex(psb_spk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_c_csr_scalplusidentity + ! end interface !> \namespace psb_base_mod \class psb_lc_csr_sparse_mat diff --git a/base/modules/serial/psb_d_csc_mat_mod.f90 b/base/modules/serial/psb_d_csc_mat_mod.f90 index c702aa83..5da0ccd3 100644 --- a/base/modules/serial/psb_d_csc_mat_mod.f90 +++ b/base/modules/serial/psb_d_csc_mat_mod.f90 @@ -71,7 +71,7 @@ module psb_d_csc_mat_mod procedure, pass(a) :: inner_cssv => psb_d_csc_cssv procedure, pass(a) :: scals => psb_d_csc_scals procedure, pass(a) :: scalv => psb_d_csc_scal - procedure, pass(a) :: scalpid => psb_d_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_d_csc_scalplusidentity procedure, pass(a) :: maxval => psb_d_csc_maxval procedure, pass(a) :: spnm1 => psb_d_csc_csnm1 procedure, pass(a) :: rowsum => psb_d_csc_rowsum @@ -128,7 +128,7 @@ module psb_d_csc_mat_mod procedure, pass(a) :: sizeof => ld_csc_sizeof procedure, pass(a) :: scals => psb_ld_csc_scals procedure, pass(a) :: scalv => psb_ld_csc_scal - procedure, pass(a) :: scalpid => psb_ld_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_ld_csc_scalplusidentity procedure, pass(a) :: maxval => psb_ld_csc_maxval procedure, pass(a) :: spnm1 => psb_ld_csc_csnm1 procedure, pass(a) :: rowsum => psb_ld_csc_rowsum @@ -565,14 +565,14 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scalplusidentity - interface - subroutine psb_d_csc_scalplusidentity(d,a,info) - import - class(psb_d_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_d_csc_scalplusidentity - end interface + ! interface + ! subroutine psb_d_csc_scalplusidentity(d,a,info) + ! import + ! class(psb_d_csc_sparse_mat), intent(inout) :: a + ! real(psb_dpk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_d_csc_scalplusidentity + ! end interface ! @@ -928,14 +928,14 @@ module psb_d_csc_mat_mod !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scalplusidentity - interface - subroutine psb_ld_csc_scalplusidentity(d,a,info) - import - class(psb_ld_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_csc_scalplusidentity - end interface +! interface +! subroutine psb_ld_csc_scalplusidentity(d,a,info) +! import +! class(psb_ld_csc_sparse_mat), intent(inout) :: a +! real(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! end subroutine psb_ld_csc_scalplusidentity +! end interface contains diff --git a/base/modules/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index 4ac24d1d..74dfe300 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -73,7 +73,7 @@ module psb_d_csr_mat_mod procedure, pass(a) :: inner_cssv => psb_d_csr_cssv procedure, pass(a) :: scals => psb_d_csr_scals procedure, pass(a) :: scalv => psb_d_csr_scal - procedure, pass(a) :: scalpid => psb_d_csr_scalplusidentity +! procedure, pass(a) :: scalpid => psb_d_csr_scalplusidentity procedure, pass(a) :: maxval => psb_d_csr_maxval procedure, pass(a) :: spnmi => psb_d_csr_csnmi procedure, pass(a) :: rowsum => psb_d_csr_rowsum @@ -582,14 +582,14 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scalplusidentity - interface - subroutine psb_d_csr_scalplusidentity(d,a,info) - import - class(psb_d_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_d_csr_scalplusidentity - end interface + ! interface + ! subroutine psb_d_csr_scalplusidentity(d,a,info) + ! import + ! class(psb_d_csr_sparse_mat), intent(inout) :: a + ! real(psb_dpk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_d_csr_scalplusidentity + ! end interface !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat diff --git a/base/modules/serial/psb_s_csc_mat_mod.f90 b/base/modules/serial/psb_s_csc_mat_mod.f90 index 500379a7..f513cb72 100644 --- a/base/modules/serial/psb_s_csc_mat_mod.f90 +++ b/base/modules/serial/psb_s_csc_mat_mod.f90 @@ -71,7 +71,7 @@ module psb_s_csc_mat_mod procedure, pass(a) :: inner_cssv => psb_s_csc_cssv procedure, pass(a) :: scals => psb_s_csc_scals procedure, pass(a) :: scalv => psb_s_csc_scal - procedure, pass(a) :: scalpid => psb_s_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_s_csc_scalplusidentity procedure, pass(a) :: maxval => psb_s_csc_maxval procedure, pass(a) :: spnm1 => psb_s_csc_csnm1 procedure, pass(a) :: rowsum => psb_s_csc_rowsum @@ -128,7 +128,7 @@ module psb_s_csc_mat_mod procedure, pass(a) :: sizeof => ls_csc_sizeof procedure, pass(a) :: scals => psb_ls_csc_scals procedure, pass(a) :: scalv => psb_ls_csc_scal - procedure, pass(a) :: scalpid => psb_ls_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_ls_csc_scalplusidentity procedure, pass(a) :: maxval => psb_ls_csc_maxval procedure, pass(a) :: spnm1 => psb_ls_csc_csnm1 procedure, pass(a) :: rowsum => psb_ls_csc_rowsum @@ -565,14 +565,14 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scalplusidentity - interface - subroutine psb_s_csc_scalplusidentity(d,a,info) - import - class(psb_s_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_s_csc_scalplusidentity - end interface + ! interface + ! subroutine psb_s_csc_scalplusidentity(d,a,info) + ! import + ! class(psb_s_csc_sparse_mat), intent(inout) :: a + ! real(psb_spk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_s_csc_scalplusidentity + ! end interface ! @@ -928,14 +928,14 @@ module psb_s_csc_mat_mod !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scalplusidentity - interface - subroutine psb_ls_csc_scalplusidentity(d,a,info) - import - class(psb_ls_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ls_csc_scalplusidentity - end interface +! interface +! subroutine psb_ls_csc_scalplusidentity(d,a,info) +! import +! class(psb_ls_csc_sparse_mat), intent(inout) :: a +! real(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! end subroutine psb_ls_csc_scalplusidentity +! end interface contains diff --git a/base/modules/serial/psb_s_csr_mat_mod.f90 b/base/modules/serial/psb_s_csr_mat_mod.f90 index 2e92151d..4a3cae6e 100644 --- a/base/modules/serial/psb_s_csr_mat_mod.f90 +++ b/base/modules/serial/psb_s_csr_mat_mod.f90 @@ -73,7 +73,7 @@ module psb_s_csr_mat_mod procedure, pass(a) :: inner_cssv => psb_s_csr_cssv procedure, pass(a) :: scals => psb_s_csr_scals procedure, pass(a) :: scalv => psb_s_csr_scal - procedure, pass(a) :: scalpid => psb_s_csr_scalplusidentity +! procedure, pass(a) :: scalpid => psb_s_csr_scalplusidentity procedure, pass(a) :: maxval => psb_s_csr_maxval procedure, pass(a) :: spnmi => psb_s_csr_csnmi procedure, pass(a) :: rowsum => psb_s_csr_rowsum @@ -582,14 +582,14 @@ module psb_s_csr_mat_mod !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scalplusidentity - interface - subroutine psb_s_csr_scalplusidentity(d,a,info) - import - class(psb_s_csr_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_s_csr_scalplusidentity - end interface + ! interface + ! subroutine psb_s_csr_scalplusidentity(d,a,info) + ! import + ! class(psb_s_csr_sparse_mat), intent(inout) :: a + ! real(psb_spk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_s_csr_scalplusidentity + ! end interface !> \namespace psb_base_mod \class psb_ls_csr_sparse_mat diff --git a/base/modules/serial/psb_z_csc_mat_mod.f90 b/base/modules/serial/psb_z_csc_mat_mod.f90 index 7eb23606..05c62cb8 100644 --- a/base/modules/serial/psb_z_csc_mat_mod.f90 +++ b/base/modules/serial/psb_z_csc_mat_mod.f90 @@ -71,7 +71,7 @@ module psb_z_csc_mat_mod procedure, pass(a) :: inner_cssv => psb_z_csc_cssv procedure, pass(a) :: scals => psb_z_csc_scals procedure, pass(a) :: scalv => psb_z_csc_scal - procedure, pass(a) :: scalpid => psb_z_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_z_csc_scalplusidentity procedure, pass(a) :: maxval => psb_z_csc_maxval procedure, pass(a) :: spnm1 => psb_z_csc_csnm1 procedure, pass(a) :: rowsum => psb_z_csc_rowsum @@ -128,7 +128,7 @@ module psb_z_csc_mat_mod procedure, pass(a) :: sizeof => lz_csc_sizeof procedure, pass(a) :: scals => psb_lz_csc_scals procedure, pass(a) :: scalv => psb_lz_csc_scal - procedure, pass(a) :: scalpid => psb_lz_csc_scalplusidentity +! procedure, pass(a) :: scalpid => psb_lz_csc_scalplusidentity procedure, pass(a) :: maxval => psb_lz_csc_maxval procedure, pass(a) :: spnm1 => psb_lz_csc_csnm1 procedure, pass(a) :: rowsum => psb_lz_csc_rowsum @@ -565,14 +565,14 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scalplusidentity - interface - subroutine psb_z_csc_scalplusidentity(d,a,info) - import - class(psb_z_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_z_csc_scalplusidentity - end interface + ! interface + ! subroutine psb_z_csc_scalplusidentity(d,a,info) + ! import + ! class(psb_z_csc_sparse_mat), intent(inout) :: a + ! complex(psb_dpk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_z_csc_scalplusidentity + ! end interface ! @@ -928,14 +928,14 @@ module psb_z_csc_mat_mod !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scalplusidentity - interface - subroutine psb_lz_csc_scalplusidentity(d,a,info) - import - class(psb_lz_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lz_csc_scalplusidentity - end interface +! interface +! subroutine psb_lz_csc_scalplusidentity(d,a,info) +! import +! class(psb_lz_csc_sparse_mat), intent(inout) :: a +! complex(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! end subroutine psb_lz_csc_scalplusidentity +! end interface contains diff --git a/base/modules/serial/psb_z_csr_mat_mod.f90 b/base/modules/serial/psb_z_csr_mat_mod.f90 index a7d5cf71..cf11e1dd 100644 --- a/base/modules/serial/psb_z_csr_mat_mod.f90 +++ b/base/modules/serial/psb_z_csr_mat_mod.f90 @@ -73,7 +73,7 @@ module psb_z_csr_mat_mod procedure, pass(a) :: inner_cssv => psb_z_csr_cssv procedure, pass(a) :: scals => psb_z_csr_scals procedure, pass(a) :: scalv => psb_z_csr_scal - procedure, pass(a) :: scalpid => psb_z_csr_scalplusidentity +! procedure, pass(a) :: scalpid => psb_z_csr_scalplusidentity procedure, pass(a) :: maxval => psb_z_csr_maxval procedure, pass(a) :: spnmi => psb_z_csr_csnmi procedure, pass(a) :: rowsum => psb_z_csr_rowsum @@ -582,14 +582,14 @@ module psb_z_csr_mat_mod !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scalplusidentity - interface - subroutine psb_z_csr_scalplusidentity(d,a,info) - import - class(psb_z_csr_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_z_csr_scalplusidentity - end interface + ! interface + ! subroutine psb_z_csr_scalplusidentity(d,a,info) + ! import + ! class(psb_z_csr_sparse_mat), intent(inout) :: a + ! complex(psb_dpk_), intent(in) :: d + ! integer(psb_ipk_), intent(out) :: info + ! end subroutine psb_z_csr_scalplusidentity + ! end interface !> \namespace psb_base_mod \class psb_lz_csr_sparse_mat diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 5ac480e6..6d7824be 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -1561,16 +1561,38 @@ subroutine psb_c_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='c_scalplusidentity' logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_c_base_scalplusidentity subroutine psb_c_base_scal(d,a,info,side) @@ -3629,16 +3651,38 @@ subroutine psb_lc_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='lc_scalplusidentity' logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_lc_base_scalplusidentity subroutine psb_lc_base_scal(d,a,info,side) diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index 5530f8ef..419ee70d 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -1485,48 +1485,48 @@ subroutine psb_c_csc_scals(d,a,info) end subroutine psb_c_csc_scals -subroutine psb_c_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scalplusidentity - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + cone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_c_csc_scalplusidentity +! subroutine psb_c_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scalplusidentity +! implicit none +! class(psb_c_csc_sparse_mat), intent(inout) :: a +! complex(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! integer(psb_ipk_) :: ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + cone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_c_csc_scalplusidentity ! == =================================== @@ -3107,48 +3107,48 @@ subroutine psb_lc_csc_scals(d,a,info) end subroutine psb_lc_csc_scals -subroutine psb_lc_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_scalplusidentity - implicit none - class(psb_lc_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: mnm, i, j, k, m - integer(psb_ipk_) :: err_act, ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + cone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lc_csc_scalplusidentity +! subroutine psb_lc_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_scalplusidentity +! implicit none +! class(psb_lc_csc_sparse_mat), intent(inout) :: a +! complex(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_lpk_) :: mnm, i, j, k, m +! integer(psb_ipk_) :: err_act, ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + cone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_lc_csc_scalplusidentity function psb_lc_csc_maxval(a) result(res) use psb_error_mod diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index 84dc4767..22f0850f 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -1677,46 +1677,46 @@ subroutine psb_c_csr_scals(d,a,info) end subroutine psb_c_csr_scals -subroutine psb_c_csr_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scalplusidentity - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + cone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -end subroutine psb_c_csr_scalplusidentity +! subroutine psb_c_csr_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scalplusidentity +! implicit none +! class(psb_c_csr_sparse_mat), intent(inout) :: a +! complex(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%irp(i),a%irp(i+1)-1 +! j=a%ja(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + cone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! return +! +! end subroutine psb_c_csr_scalplusidentity diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index 65bc1bff..30cb4d1e 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -1561,16 +1561,38 @@ subroutine psb_d_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='d_scalplusidentity' logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_d_base_scalplusidentity subroutine psb_d_base_scal(d,a,info,side) @@ -3629,16 +3651,38 @@ subroutine psb_ld_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='ld_scalplusidentity' logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_ld_base_scalplusidentity subroutine psb_ld_base_scal(d,a,info,side) diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index 832f6729..f55ce774 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -1485,48 +1485,48 @@ subroutine psb_d_csc_scals(d,a,info) end subroutine psb_d_csc_scals -subroutine psb_d_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scalplusidentity - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + done - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_d_csc_scalplusidentity +! subroutine psb_d_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scalplusidentity +! implicit none +! class(psb_d_csc_sparse_mat), intent(inout) :: a +! real(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! integer(psb_ipk_) :: ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + done +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_d_csc_scalplusidentity ! == =================================== @@ -3107,48 +3107,48 @@ subroutine psb_ld_csc_scals(d,a,info) end subroutine psb_ld_csc_scals -subroutine psb_ld_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_scalplusidentity - implicit none - class(psb_ld_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: mnm, i, j, k, m - integer(psb_ipk_) :: err_act, ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + done - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ld_csc_scalplusidentity +! subroutine psb_ld_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_scalplusidentity +! implicit none +! class(psb_ld_csc_sparse_mat), intent(inout) :: a +! real(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_lpk_) :: mnm, i, j, k, m +! integer(psb_ipk_) :: err_act, ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + done +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_ld_csc_scalplusidentity function psb_ld_csc_maxval(a) result(res) use psb_error_mod diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index 3c306a4c..70c2515e 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -1677,46 +1677,46 @@ subroutine psb_d_csr_scals(d,a,info) end subroutine psb_d_csr_scals -subroutine psb_d_csr_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scalplusidentity - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + done - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -end subroutine psb_d_csr_scalplusidentity +! subroutine psb_d_csr_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scalplusidentity +! implicit none +! class(psb_d_csr_sparse_mat), intent(inout) :: a +! real(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%irp(i),a%irp(i+1)-1 +! j=a%ja(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + done +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! return +! +! end subroutine psb_d_csr_scalplusidentity diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 1e791b36..7a3f647d 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -1561,16 +1561,38 @@ subroutine psb_s_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='s_scalplusidentity' logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_s_base_scalplusidentity subroutine psb_s_base_scal(d,a,info,side) @@ -3629,16 +3651,38 @@ subroutine psb_ls_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='ls_scalplusidentity' logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_ls_base_scalplusidentity subroutine psb_ls_base_scal(d,a,info,side) diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index 6abd15c2..fcd00755 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -1485,48 +1485,48 @@ subroutine psb_s_csc_scals(d,a,info) end subroutine psb_s_csc_scals -subroutine psb_s_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scalplusidentity - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + sone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_s_csc_scalplusidentity +! subroutine psb_s_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scalplusidentity +! implicit none +! class(psb_s_csc_sparse_mat), intent(inout) :: a +! real(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! integer(psb_ipk_) :: ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + sone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_s_csc_scalplusidentity ! == =================================== @@ -3107,48 +3107,48 @@ subroutine psb_ls_csc_scals(d,a,info) end subroutine psb_ls_csc_scals -subroutine psb_ls_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_scalplusidentity - implicit none - class(psb_ls_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: mnm, i, j, k, m - integer(psb_ipk_) :: err_act, ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + sone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_ls_csc_scalplusidentity +! subroutine psb_ls_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_scalplusidentity +! implicit none +! class(psb_ls_csc_sparse_mat), intent(inout) :: a +! real(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_lpk_) :: mnm, i, j, k, m +! integer(psb_ipk_) :: err_act, ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + sone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_ls_csc_scalplusidentity function psb_ls_csc_maxval(a) result(res) use psb_error_mod diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 3083c6bc..18c285ab 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -1677,46 +1677,46 @@ subroutine psb_s_csr_scals(d,a,info) end subroutine psb_s_csr_scals -subroutine psb_s_csr_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scalplusidentity - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + sone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -end subroutine psb_s_csr_scalplusidentity +! subroutine psb_s_csr_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scalplusidentity +! implicit none +! class(psb_s_csr_sparse_mat), intent(inout) :: a +! real(psb_spk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%irp(i),a%irp(i+1)-1 +! j=a%ja(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + sone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! return +! +! end subroutine psb_s_csr_scalplusidentity diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index d54000ff..fbbbd83d 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -1561,16 +1561,38 @@ subroutine psb_z_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='z_scalplusidentity' logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_z_base_scalplusidentity subroutine psb_z_base_scal(d,a,info,side) @@ -3629,16 +3651,38 @@ subroutine psb_lz_base_scalplusidentity(d,a,info) integer(psb_ipk_) :: err_act character(len=20) :: name='lz_scalplusidentity' logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: acoo call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if call psb_error_handler(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_lz_base_scalplusidentity subroutine psb_lz_base_scal(d,a,info,side) diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index ccbaefd6..715673ce 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -1485,48 +1485,48 @@ subroutine psb_z_csc_scals(d,a,info) end subroutine psb_z_csc_scals -subroutine psb_z_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scalplusidentity - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + zone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_z_csc_scalplusidentity +! subroutine psb_z_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scalplusidentity +! implicit none +! class(psb_z_csc_sparse_mat), intent(inout) :: a +! complex(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! integer(psb_ipk_) :: ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + zone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_z_csc_scalplusidentity ! == =================================== @@ -3107,48 +3107,48 @@ subroutine psb_lz_csc_scals(d,a,info) end subroutine psb_lz_csc_scals -subroutine psb_lz_csc_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_scalplusidentity - implicit none - class(psb_lz_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_lpk_) :: mnm, i, j, k, m - integer(psb_ipk_) :: err_act, ierr(5) - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + zone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_lz_csc_scalplusidentity +! subroutine psb_lz_csc_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_scalplusidentity +! implicit none +! class(psb_lz_csc_sparse_mat), intent(inout) :: a +! complex(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_lpk_) :: mnm, i, j, k, m +! integer(psb_ipk_) :: err_act, ierr(5) +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%icp(i),a%icp(i+1)-1 +! j=a%ia(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + zone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! +! return +! +! end subroutine psb_lz_csc_scalplusidentity function psb_lz_csc_maxval(a) result(res) use psb_error_mod diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index 5b9ca993..6071f563 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -1677,46 +1677,46 @@ subroutine psb_z_csr_scals(d,a,info) end subroutine psb_z_csr_scals -subroutine psb_z_csr_scalplusidentity(d,a,info) - use psb_error_mod - use psb_const_mod - use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scalplusidentity - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: err_act,mnm, i, j, k, m - character(len=20) :: name='scalplusidentity' - logical, parameter :: debug=.false. - - info = psb_success_ - call psb_erractionsave(err_act) - if (a%is_dev()) call a%sync() - - if (a%is_unit()) then - call a%make_nonunit() - end if - - mnm = min(a%get_nrows(),a%get_ncols()) - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then - a%val(k) = a%val(k) + zone - endif - enddo - enddo - call a%set_host() - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - -end subroutine psb_z_csr_scalplusidentity +! subroutine psb_z_csr_scalplusidentity(d,a,info) +! use psb_error_mod +! use psb_const_mod +! use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scalplusidentity +! implicit none +! class(psb_z_csr_sparse_mat), intent(inout) :: a +! complex(psb_dpk_), intent(in) :: d +! integer(psb_ipk_), intent(out) :: info +! +! integer(psb_ipk_) :: err_act,mnm, i, j, k, m +! character(len=20) :: name='scalplusidentity' +! logical, parameter :: debug=.false. +! +! info = psb_success_ +! call psb_erractionsave(err_act) +! if (a%is_dev()) call a%sync() +! +! if (a%is_unit()) then +! call a%make_nonunit() +! end if +! +! mnm = min(a%get_nrows(),a%get_ncols()) +! do i=1,a%get_nzeros() +! a%val(i) = a%val(i) * d +! do k=a%irp(i),a%irp(i+1)-1 +! j=a%ja(k) +! if ((j == i) .and.(j <= mnm )) then +! a%val(k) = a%val(k) + zone +! endif +! enddo +! enddo +! call a%set_host() +! +! call psb_erractionrestore(err_act) +! return +! +! 9999 call psb_error_handler(err_act) +! return +! +! end subroutine psb_z_csr_scalplusidentity