From b74339d2d5ed1c56b3c2453126bc20dc30d18790 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 23 Apr 2024 10:25:28 +0200 Subject: [PATCH] First attempt at a vs ad/and in spmat --- base/modules/serial/psb_c_mat_mod.F90 | 98 ++- base/modules/serial/psb_d_mat_mod.F90 | 98 ++- base/modules/serial/psb_s_mat_mod.F90 | 98 ++- base/modules/serial/psb_z_mat_mod.F90 | 98 ++- base/serial/impl/psb_c_mat_impl.F90 | 1117 ++++++++++++++++--------- base/serial/impl/psb_d_mat_impl.F90 | 1117 ++++++++++++++++--------- base/serial/impl/psb_s_mat_impl.F90 | 1117 ++++++++++++++++--------- base/serial/impl/psb_z_mat_impl.F90 | 1117 ++++++++++++++++--------- 8 files changed, 3256 insertions(+), 1604 deletions(-) diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index e7c84b00..d80ed734 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -854,11 +854,13 @@ module psb_c_mat_mod end interface interface - subroutine psb_c_merge_nd(a,n_rows,n_cols,info) - import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + subroutine psb_c_merge_nd(a,n_rows,n_cols,info,acoo) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, & + & psb_c_base_sparse_mat, psb_c_coo_sparse_mat class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_c_coo_sparse_mat), intent(out), optional :: acoo end subroutine psb_c_merge_nd end interface @@ -988,7 +990,7 @@ module psb_c_mat_mod interface subroutine psb_c_cp_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat - class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_c_cp_to_lb end interface @@ -2024,6 +2026,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%sizeof() + else if (allocated(a%ad).and.allocated(a%and)) then + res = a%ad%sizeof()+a%and%sizeof() end if end function psb_c_sizeof @@ -2036,6 +2040,8 @@ contains if (allocated(a%a)) then res = a%a%get_fmt() + elseif (allocated(a%ad)) then + res = a%ad%get_fmt() else res = 'NULL' end if @@ -2050,6 +2056,8 @@ contains if (allocated(a%a)) then res = a%a%get_dupl() + else if (allocated(a%ad)) then + res = a%ad%get_dupl() else res = psb_invalid_ end if @@ -2062,6 +2070,8 @@ contains if (allocated(a%a)) then res = a%a%get_nrows() + else if (allocated(a%ad)) then + res = a%ad%get_nrows() else res = 0 end if @@ -2075,7 +2085,9 @@ contains if (allocated(a%a)) then res = a%a%get_ncols() - else + else if (allocated(a%ad)) then + res = a%ad%get_ncols() + a%and%get_ncols() + else res = 0 end if @@ -2088,7 +2100,9 @@ contains if (allocated(a%a)) then res = a%a%is_triangle() - else + else if (allocated(a%ad)) then + res = a%ad%is_triangle() + else res = .false. end if @@ -2101,6 +2115,8 @@ contains if (allocated(a%a)) then res = a%a%is_symmetric() + else if (allocated(a%ad)) then + res = a%ad%is_symmetric() else res = .false. end if @@ -2114,6 +2130,8 @@ contains if (allocated(a%a)) then res = a%a%is_unit() + else if (allocated(a%ad)) then + res = a%ad%is_unit() else res = .false. end if @@ -2127,7 +2145,9 @@ contains if (allocated(a%a)) then res = a%a%is_upper() - else + else if (allocated(a%ad)) then + res = a%ad%is_upper() + else res = .false. end if @@ -2140,7 +2160,9 @@ contains if (allocated(a%a)) then res = .not. a%a%is_upper() - else + else if (allocated(a%ad)) then + res = .not. a%ad%is_upper() + else res = .false. end if @@ -2153,12 +2175,15 @@ contains if (allocated(a%a)) then res = a%a%is_null() - else + else if (allocated(a%ad)) then + res = a%ad%is_null() + else res = .true. end if end function psb_c_is_null + ! Note: in the build state we should always have A%A function psb_c_is_bld(a) result(res) implicit none class(psb_cspmat_type), intent(in) :: a @@ -2179,7 +2204,9 @@ contains if (allocated(a%a)) then res = a%a%is_upd() - else + else if (allocated(a%ad)) then + res = a%ad%is_upd() + else res = .false. end if @@ -2192,7 +2219,9 @@ contains if (allocated(a%a)) then res = a%a%is_asb() - else + else if (allocated(a%ad)) then + res = a%ad%is_asb() + else res = .false. end if @@ -2205,6 +2234,8 @@ contains if (allocated(a%a)) then res = a%a%is_sorted() + else if (allocated(a%ad)) then + res = a%ad%is_sorted() else res = .false. end if @@ -2218,6 +2249,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_rows() + else if (allocated(a%ad)) then + res = a%ad%is_by_rows() else res = .false. end if @@ -2231,6 +2264,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_cols() + else if (allocated(a%ad)) then + res = a%ad%is_by_cols() else res = .false. end if @@ -2243,7 +2278,9 @@ contains implicit none class(psb_cspmat_type), target, intent(in) :: a - if (allocated(a%a)) call a%a%sync() + if (allocated(a%a)) call a%a%sync() + if (allocated(a%ad)) call a%ad%sync() + if (allocated(a%and)) call a%and%sync() end subroutine c_mat_sync @@ -2252,7 +2289,9 @@ contains implicit none class(psb_cspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_host() + if (allocated(a%a)) call a%a%set_host() + if (allocated(a%ad)) call a%ad%set_host() + if (allocated(a%and)) call a%and%set_host() end subroutine c_mat_set_host @@ -2262,7 +2301,9 @@ contains implicit none class(psb_cspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%ad)) call a%ad%set_dev() + if (allocated(a%and)) call a%and%set_dev() end subroutine c_mat_set_dev @@ -2271,7 +2312,9 @@ contains implicit none class(psb_cspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%ad)) call a%ad%set_sync() + if (allocated(a%and)) call a%and%set_sync() end subroutine c_mat_set_sync @@ -2283,6 +2326,8 @@ contains if (allocated(a%a)) then res = a%a%is_dev() + else if (allocated(a%ad)) then + res = a%ad%is_dev() else res = .false. end if @@ -2297,6 +2342,8 @@ contains if (allocated(a%a)) then res = a%a%is_host() + else if (allocated(a%ad)) then + res = a%ad%is_host() else res = .true. end if @@ -2311,6 +2358,8 @@ contains if (allocated(a%a)) then res = a%a%is_sync() + else if (allocated(a%ad)) then + res = a%ad%is_sync() else res = .true. end if @@ -2343,6 +2392,8 @@ contains if (allocated(a%a)) then res = a%a%is_repeatable_updates() + else if (allocated(a%ad)) then + res = a%ad%is_repeatable_updates() else res = .false. end if @@ -2356,6 +2407,9 @@ contains if (allocated(a%a)) then call a%a%set_repeatable_updates(val) + else if (allocated(a%ad)) then + call a%ad%set_repeatable_updates(val) + call a%and%set_repeatable_updates(val) end if end subroutine psb_c_set_repeatable_updates @@ -2369,6 +2423,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_nzeros() + else if (allocated(a%ad)) then + res = a%ad%get_nzeros() + a%and%get_nzeros() end if end function psb_c_get_nzeros @@ -2383,6 +2439,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_size() + else if (allocated(a%ad)) then + res = a%ad%get_size() + a%and%get_size() end if end function psb_c_get_size @@ -2396,8 +2454,12 @@ contains res = 0 - if (allocated(a%a)) res = a%a%get_nz_row(idx) - + if (allocated(a%a)) then + res = res + a%a%get_nz_row(idx) + else + if (allocated(a%ad)) res = res + a%ad%get_nz_row(idx) + if (allocated(a%and)) res = res + a%and%get_nz_row(idx) + end if end function psb_c_get_nz_row subroutine psb_c_clean_zeros(a,info) @@ -2406,7 +2468,9 @@ contains class(psb_cspmat_type), intent(inout) :: a info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%ad)) call a%ad%clean_zeros(info) + if (allocated(a%and)) call a%and%clean_zeros(info) end subroutine psb_c_clean_zeros diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index fe09d83a..d3322c45 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -854,11 +854,13 @@ module psb_d_mat_mod end interface interface - subroutine psb_d_merge_nd(a,n_rows,n_cols,info) - import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + subroutine psb_d_merge_nd(a,n_rows,n_cols,info,acoo) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, & + & psb_d_base_sparse_mat, psb_d_coo_sparse_mat class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_d_coo_sparse_mat), intent(out), optional :: acoo end subroutine psb_d_merge_nd end interface @@ -988,7 +990,7 @@ module psb_d_mat_mod interface subroutine psb_d_cp_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat - class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_d_cp_to_lb end interface @@ -2024,6 +2026,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%sizeof() + else if (allocated(a%ad).and.allocated(a%and)) then + res = a%ad%sizeof()+a%and%sizeof() end if end function psb_d_sizeof @@ -2036,6 +2040,8 @@ contains if (allocated(a%a)) then res = a%a%get_fmt() + elseif (allocated(a%ad)) then + res = a%ad%get_fmt() else res = 'NULL' end if @@ -2050,6 +2056,8 @@ contains if (allocated(a%a)) then res = a%a%get_dupl() + else if (allocated(a%ad)) then + res = a%ad%get_dupl() else res = psb_invalid_ end if @@ -2062,6 +2070,8 @@ contains if (allocated(a%a)) then res = a%a%get_nrows() + else if (allocated(a%ad)) then + res = a%ad%get_nrows() else res = 0 end if @@ -2075,7 +2085,9 @@ contains if (allocated(a%a)) then res = a%a%get_ncols() - else + else if (allocated(a%ad)) then + res = a%ad%get_ncols() + a%and%get_ncols() + else res = 0 end if @@ -2088,7 +2100,9 @@ contains if (allocated(a%a)) then res = a%a%is_triangle() - else + else if (allocated(a%ad)) then + res = a%ad%is_triangle() + else res = .false. end if @@ -2101,6 +2115,8 @@ contains if (allocated(a%a)) then res = a%a%is_symmetric() + else if (allocated(a%ad)) then + res = a%ad%is_symmetric() else res = .false. end if @@ -2114,6 +2130,8 @@ contains if (allocated(a%a)) then res = a%a%is_unit() + else if (allocated(a%ad)) then + res = a%ad%is_unit() else res = .false. end if @@ -2127,7 +2145,9 @@ contains if (allocated(a%a)) then res = a%a%is_upper() - else + else if (allocated(a%ad)) then + res = a%ad%is_upper() + else res = .false. end if @@ -2140,7 +2160,9 @@ contains if (allocated(a%a)) then res = .not. a%a%is_upper() - else + else if (allocated(a%ad)) then + res = .not. a%ad%is_upper() + else res = .false. end if @@ -2153,12 +2175,15 @@ contains if (allocated(a%a)) then res = a%a%is_null() - else + else if (allocated(a%ad)) then + res = a%ad%is_null() + else res = .true. end if end function psb_d_is_null + ! Note: in the build state we should always have A%A function psb_d_is_bld(a) result(res) implicit none class(psb_dspmat_type), intent(in) :: a @@ -2179,7 +2204,9 @@ contains if (allocated(a%a)) then res = a%a%is_upd() - else + else if (allocated(a%ad)) then + res = a%ad%is_upd() + else res = .false. end if @@ -2192,7 +2219,9 @@ contains if (allocated(a%a)) then res = a%a%is_asb() - else + else if (allocated(a%ad)) then + res = a%ad%is_asb() + else res = .false. end if @@ -2205,6 +2234,8 @@ contains if (allocated(a%a)) then res = a%a%is_sorted() + else if (allocated(a%ad)) then + res = a%ad%is_sorted() else res = .false. end if @@ -2218,6 +2249,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_rows() + else if (allocated(a%ad)) then + res = a%ad%is_by_rows() else res = .false. end if @@ -2231,6 +2264,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_cols() + else if (allocated(a%ad)) then + res = a%ad%is_by_cols() else res = .false. end if @@ -2243,7 +2278,9 @@ contains implicit none class(psb_dspmat_type), target, intent(in) :: a - if (allocated(a%a)) call a%a%sync() + if (allocated(a%a)) call a%a%sync() + if (allocated(a%ad)) call a%ad%sync() + if (allocated(a%and)) call a%and%sync() end subroutine d_mat_sync @@ -2252,7 +2289,9 @@ contains implicit none class(psb_dspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_host() + if (allocated(a%a)) call a%a%set_host() + if (allocated(a%ad)) call a%ad%set_host() + if (allocated(a%and)) call a%and%set_host() end subroutine d_mat_set_host @@ -2262,7 +2301,9 @@ contains implicit none class(psb_dspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%ad)) call a%ad%set_dev() + if (allocated(a%and)) call a%and%set_dev() end subroutine d_mat_set_dev @@ -2271,7 +2312,9 @@ contains implicit none class(psb_dspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%ad)) call a%ad%set_sync() + if (allocated(a%and)) call a%and%set_sync() end subroutine d_mat_set_sync @@ -2283,6 +2326,8 @@ contains if (allocated(a%a)) then res = a%a%is_dev() + else if (allocated(a%ad)) then + res = a%ad%is_dev() else res = .false. end if @@ -2297,6 +2342,8 @@ contains if (allocated(a%a)) then res = a%a%is_host() + else if (allocated(a%ad)) then + res = a%ad%is_host() else res = .true. end if @@ -2311,6 +2358,8 @@ contains if (allocated(a%a)) then res = a%a%is_sync() + else if (allocated(a%ad)) then + res = a%ad%is_sync() else res = .true. end if @@ -2343,6 +2392,8 @@ contains if (allocated(a%a)) then res = a%a%is_repeatable_updates() + else if (allocated(a%ad)) then + res = a%ad%is_repeatable_updates() else res = .false. end if @@ -2356,6 +2407,9 @@ contains if (allocated(a%a)) then call a%a%set_repeatable_updates(val) + else if (allocated(a%ad)) then + call a%ad%set_repeatable_updates(val) + call a%and%set_repeatable_updates(val) end if end subroutine psb_d_set_repeatable_updates @@ -2369,6 +2423,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_nzeros() + else if (allocated(a%ad)) then + res = a%ad%get_nzeros() + a%and%get_nzeros() end if end function psb_d_get_nzeros @@ -2383,6 +2439,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_size() + else if (allocated(a%ad)) then + res = a%ad%get_size() + a%and%get_size() end if end function psb_d_get_size @@ -2396,8 +2454,12 @@ contains res = 0 - if (allocated(a%a)) res = a%a%get_nz_row(idx) - + if (allocated(a%a)) then + res = res + a%a%get_nz_row(idx) + else + if (allocated(a%ad)) res = res + a%ad%get_nz_row(idx) + if (allocated(a%and)) res = res + a%and%get_nz_row(idx) + end if end function psb_d_get_nz_row subroutine psb_d_clean_zeros(a,info) @@ -2406,7 +2468,9 @@ contains class(psb_dspmat_type), intent(inout) :: a info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%ad)) call a%ad%clean_zeros(info) + if (allocated(a%and)) call a%and%clean_zeros(info) end subroutine psb_d_clean_zeros diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 868583b2..8d3dcbe4 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -854,11 +854,13 @@ module psb_s_mat_mod end interface interface - subroutine psb_s_merge_nd(a,n_rows,n_cols,info) - import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + subroutine psb_s_merge_nd(a,n_rows,n_cols,info,acoo) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, & + & psb_s_base_sparse_mat, psb_s_coo_sparse_mat class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_s_coo_sparse_mat), intent(out), optional :: acoo end subroutine psb_s_merge_nd end interface @@ -988,7 +990,7 @@ module psb_s_mat_mod interface subroutine psb_s_cp_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat - class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_s_cp_to_lb end interface @@ -2024,6 +2026,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%sizeof() + else if (allocated(a%ad).and.allocated(a%and)) then + res = a%ad%sizeof()+a%and%sizeof() end if end function psb_s_sizeof @@ -2036,6 +2040,8 @@ contains if (allocated(a%a)) then res = a%a%get_fmt() + elseif (allocated(a%ad)) then + res = a%ad%get_fmt() else res = 'NULL' end if @@ -2050,6 +2056,8 @@ contains if (allocated(a%a)) then res = a%a%get_dupl() + else if (allocated(a%ad)) then + res = a%ad%get_dupl() else res = psb_invalid_ end if @@ -2062,6 +2070,8 @@ contains if (allocated(a%a)) then res = a%a%get_nrows() + else if (allocated(a%ad)) then + res = a%ad%get_nrows() else res = 0 end if @@ -2075,7 +2085,9 @@ contains if (allocated(a%a)) then res = a%a%get_ncols() - else + else if (allocated(a%ad)) then + res = a%ad%get_ncols() + a%and%get_ncols() + else res = 0 end if @@ -2088,7 +2100,9 @@ contains if (allocated(a%a)) then res = a%a%is_triangle() - else + else if (allocated(a%ad)) then + res = a%ad%is_triangle() + else res = .false. end if @@ -2101,6 +2115,8 @@ contains if (allocated(a%a)) then res = a%a%is_symmetric() + else if (allocated(a%ad)) then + res = a%ad%is_symmetric() else res = .false. end if @@ -2114,6 +2130,8 @@ contains if (allocated(a%a)) then res = a%a%is_unit() + else if (allocated(a%ad)) then + res = a%ad%is_unit() else res = .false. end if @@ -2127,7 +2145,9 @@ contains if (allocated(a%a)) then res = a%a%is_upper() - else + else if (allocated(a%ad)) then + res = a%ad%is_upper() + else res = .false. end if @@ -2140,7 +2160,9 @@ contains if (allocated(a%a)) then res = .not. a%a%is_upper() - else + else if (allocated(a%ad)) then + res = .not. a%ad%is_upper() + else res = .false. end if @@ -2153,12 +2175,15 @@ contains if (allocated(a%a)) then res = a%a%is_null() - else + else if (allocated(a%ad)) then + res = a%ad%is_null() + else res = .true. end if end function psb_s_is_null + ! Note: in the build state we should always have A%A function psb_s_is_bld(a) result(res) implicit none class(psb_sspmat_type), intent(in) :: a @@ -2179,7 +2204,9 @@ contains if (allocated(a%a)) then res = a%a%is_upd() - else + else if (allocated(a%ad)) then + res = a%ad%is_upd() + else res = .false. end if @@ -2192,7 +2219,9 @@ contains if (allocated(a%a)) then res = a%a%is_asb() - else + else if (allocated(a%ad)) then + res = a%ad%is_asb() + else res = .false. end if @@ -2205,6 +2234,8 @@ contains if (allocated(a%a)) then res = a%a%is_sorted() + else if (allocated(a%ad)) then + res = a%ad%is_sorted() else res = .false. end if @@ -2218,6 +2249,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_rows() + else if (allocated(a%ad)) then + res = a%ad%is_by_rows() else res = .false. end if @@ -2231,6 +2264,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_cols() + else if (allocated(a%ad)) then + res = a%ad%is_by_cols() else res = .false. end if @@ -2243,7 +2278,9 @@ contains implicit none class(psb_sspmat_type), target, intent(in) :: a - if (allocated(a%a)) call a%a%sync() + if (allocated(a%a)) call a%a%sync() + if (allocated(a%ad)) call a%ad%sync() + if (allocated(a%and)) call a%and%sync() end subroutine s_mat_sync @@ -2252,7 +2289,9 @@ contains implicit none class(psb_sspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_host() + if (allocated(a%a)) call a%a%set_host() + if (allocated(a%ad)) call a%ad%set_host() + if (allocated(a%and)) call a%and%set_host() end subroutine s_mat_set_host @@ -2262,7 +2301,9 @@ contains implicit none class(psb_sspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%ad)) call a%ad%set_dev() + if (allocated(a%and)) call a%and%set_dev() end subroutine s_mat_set_dev @@ -2271,7 +2312,9 @@ contains implicit none class(psb_sspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%ad)) call a%ad%set_sync() + if (allocated(a%and)) call a%and%set_sync() end subroutine s_mat_set_sync @@ -2283,6 +2326,8 @@ contains if (allocated(a%a)) then res = a%a%is_dev() + else if (allocated(a%ad)) then + res = a%ad%is_dev() else res = .false. end if @@ -2297,6 +2342,8 @@ contains if (allocated(a%a)) then res = a%a%is_host() + else if (allocated(a%ad)) then + res = a%ad%is_host() else res = .true. end if @@ -2311,6 +2358,8 @@ contains if (allocated(a%a)) then res = a%a%is_sync() + else if (allocated(a%ad)) then + res = a%ad%is_sync() else res = .true. end if @@ -2343,6 +2392,8 @@ contains if (allocated(a%a)) then res = a%a%is_repeatable_updates() + else if (allocated(a%ad)) then + res = a%ad%is_repeatable_updates() else res = .false. end if @@ -2356,6 +2407,9 @@ contains if (allocated(a%a)) then call a%a%set_repeatable_updates(val) + else if (allocated(a%ad)) then + call a%ad%set_repeatable_updates(val) + call a%and%set_repeatable_updates(val) end if end subroutine psb_s_set_repeatable_updates @@ -2369,6 +2423,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_nzeros() + else if (allocated(a%ad)) then + res = a%ad%get_nzeros() + a%and%get_nzeros() end if end function psb_s_get_nzeros @@ -2383,6 +2439,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_size() + else if (allocated(a%ad)) then + res = a%ad%get_size() + a%and%get_size() end if end function psb_s_get_size @@ -2396,8 +2454,12 @@ contains res = 0 - if (allocated(a%a)) res = a%a%get_nz_row(idx) - + if (allocated(a%a)) then + res = res + a%a%get_nz_row(idx) + else + if (allocated(a%ad)) res = res + a%ad%get_nz_row(idx) + if (allocated(a%and)) res = res + a%and%get_nz_row(idx) + end if end function psb_s_get_nz_row subroutine psb_s_clean_zeros(a,info) @@ -2406,7 +2468,9 @@ contains class(psb_sspmat_type), intent(inout) :: a info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%ad)) call a%ad%clean_zeros(info) + if (allocated(a%and)) call a%and%clean_zeros(info) end subroutine psb_s_clean_zeros diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index 48b670de..51556032 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -854,11 +854,13 @@ module psb_z_mat_mod end interface interface - subroutine psb_z_merge_nd(a,n_rows,n_cols,info) - import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + subroutine psb_z_merge_nd(a,n_rows,n_cols,info,acoo) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, & + & psb_z_base_sparse_mat, psb_z_coo_sparse_mat class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_z_coo_sparse_mat), intent(out), optional :: acoo end subroutine psb_z_merge_nd end interface @@ -988,7 +990,7 @@ module psb_z_mat_mod interface subroutine psb_z_cp_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat - class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_z_cp_to_lb end interface @@ -2024,6 +2026,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%sizeof() + else if (allocated(a%ad).and.allocated(a%and)) then + res = a%ad%sizeof()+a%and%sizeof() end if end function psb_z_sizeof @@ -2036,6 +2040,8 @@ contains if (allocated(a%a)) then res = a%a%get_fmt() + elseif (allocated(a%ad)) then + res = a%ad%get_fmt() else res = 'NULL' end if @@ -2050,6 +2056,8 @@ contains if (allocated(a%a)) then res = a%a%get_dupl() + else if (allocated(a%ad)) then + res = a%ad%get_dupl() else res = psb_invalid_ end if @@ -2062,6 +2070,8 @@ contains if (allocated(a%a)) then res = a%a%get_nrows() + else if (allocated(a%ad)) then + res = a%ad%get_nrows() else res = 0 end if @@ -2075,7 +2085,9 @@ contains if (allocated(a%a)) then res = a%a%get_ncols() - else + else if (allocated(a%ad)) then + res = a%ad%get_ncols() + a%and%get_ncols() + else res = 0 end if @@ -2088,7 +2100,9 @@ contains if (allocated(a%a)) then res = a%a%is_triangle() - else + else if (allocated(a%ad)) then + res = a%ad%is_triangle() + else res = .false. end if @@ -2101,6 +2115,8 @@ contains if (allocated(a%a)) then res = a%a%is_symmetric() + else if (allocated(a%ad)) then + res = a%ad%is_symmetric() else res = .false. end if @@ -2114,6 +2130,8 @@ contains if (allocated(a%a)) then res = a%a%is_unit() + else if (allocated(a%ad)) then + res = a%ad%is_unit() else res = .false. end if @@ -2127,7 +2145,9 @@ contains if (allocated(a%a)) then res = a%a%is_upper() - else + else if (allocated(a%ad)) then + res = a%ad%is_upper() + else res = .false. end if @@ -2140,7 +2160,9 @@ contains if (allocated(a%a)) then res = .not. a%a%is_upper() - else + else if (allocated(a%ad)) then + res = .not. a%ad%is_upper() + else res = .false. end if @@ -2153,12 +2175,15 @@ contains if (allocated(a%a)) then res = a%a%is_null() - else + else if (allocated(a%ad)) then + res = a%ad%is_null() + else res = .true. end if end function psb_z_is_null + ! Note: in the build state we should always have A%A function psb_z_is_bld(a) result(res) implicit none class(psb_zspmat_type), intent(in) :: a @@ -2179,7 +2204,9 @@ contains if (allocated(a%a)) then res = a%a%is_upd() - else + else if (allocated(a%ad)) then + res = a%ad%is_upd() + else res = .false. end if @@ -2192,7 +2219,9 @@ contains if (allocated(a%a)) then res = a%a%is_asb() - else + else if (allocated(a%ad)) then + res = a%ad%is_asb() + else res = .false. end if @@ -2205,6 +2234,8 @@ contains if (allocated(a%a)) then res = a%a%is_sorted() + else if (allocated(a%ad)) then + res = a%ad%is_sorted() else res = .false. end if @@ -2218,6 +2249,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_rows() + else if (allocated(a%ad)) then + res = a%ad%is_by_rows() else res = .false. end if @@ -2231,6 +2264,8 @@ contains if (allocated(a%a)) then res = a%a%is_by_cols() + else if (allocated(a%ad)) then + res = a%ad%is_by_cols() else res = .false. end if @@ -2243,7 +2278,9 @@ contains implicit none class(psb_zspmat_type), target, intent(in) :: a - if (allocated(a%a)) call a%a%sync() + if (allocated(a%a)) call a%a%sync() + if (allocated(a%ad)) call a%ad%sync() + if (allocated(a%and)) call a%and%sync() end subroutine z_mat_sync @@ -2252,7 +2289,9 @@ contains implicit none class(psb_zspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_host() + if (allocated(a%a)) call a%a%set_host() + if (allocated(a%ad)) call a%ad%set_host() + if (allocated(a%and)) call a%and%set_host() end subroutine z_mat_set_host @@ -2262,7 +2301,9 @@ contains implicit none class(psb_zspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%a)) call a%a%set_dev() + if (allocated(a%ad)) call a%ad%set_dev() + if (allocated(a%and)) call a%and%set_dev() end subroutine z_mat_set_dev @@ -2271,7 +2312,9 @@ contains implicit none class(psb_zspmat_type), intent(inout) :: a - if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%a)) call a%a%set_sync() + if (allocated(a%ad)) call a%ad%set_sync() + if (allocated(a%and)) call a%and%set_sync() end subroutine z_mat_set_sync @@ -2283,6 +2326,8 @@ contains if (allocated(a%a)) then res = a%a%is_dev() + else if (allocated(a%ad)) then + res = a%ad%is_dev() else res = .false. end if @@ -2297,6 +2342,8 @@ contains if (allocated(a%a)) then res = a%a%is_host() + else if (allocated(a%ad)) then + res = a%ad%is_host() else res = .true. end if @@ -2311,6 +2358,8 @@ contains if (allocated(a%a)) then res = a%a%is_sync() + else if (allocated(a%ad)) then + res = a%ad%is_sync() else res = .true. end if @@ -2343,6 +2392,8 @@ contains if (allocated(a%a)) then res = a%a%is_repeatable_updates() + else if (allocated(a%ad)) then + res = a%ad%is_repeatable_updates() else res = .false. end if @@ -2356,6 +2407,9 @@ contains if (allocated(a%a)) then call a%a%set_repeatable_updates(val) + else if (allocated(a%ad)) then + call a%ad%set_repeatable_updates(val) + call a%and%set_repeatable_updates(val) end if end subroutine psb_z_set_repeatable_updates @@ -2369,6 +2423,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_nzeros() + else if (allocated(a%ad)) then + res = a%ad%get_nzeros() + a%and%get_nzeros() end if end function psb_z_get_nzeros @@ -2383,6 +2439,8 @@ contains res = 0 if (allocated(a%a)) then res = a%a%get_size() + else if (allocated(a%ad)) then + res = a%ad%get_size() + a%and%get_size() end if end function psb_z_get_size @@ -2396,8 +2454,12 @@ contains res = 0 - if (allocated(a%a)) res = a%a%get_nz_row(idx) - + if (allocated(a%a)) then + res = res + a%a%get_nz_row(idx) + else + if (allocated(a%ad)) res = res + a%ad%get_nz_row(idx) + if (allocated(a%and)) res = res + a%and%get_nz_row(idx) + end if end function psb_z_get_nz_row subroutine psb_z_clean_zeros(a,info) @@ -2406,7 +2468,9 @@ contains class(psb_zspmat_type), intent(inout) :: a info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%a)) call a%a%clean_zeros(info) + if (allocated(a%ad)) call a%ad%clean_zeros(info) + if (allocated(a%and)) call a%and%clean_zeros(info) end subroutine psb_z_clean_zeros diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 532cb9b8..b98408c7 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -64,14 +64,17 @@ subroutine psb_c_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_nrows(m) + else if (allocated(a%ad)) then + call a%ad%set_nrows(m) + call a%and%set_nrows(m) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_nrows(m) - call psb_erractionrestore(err_act) return @@ -91,14 +94,20 @@ subroutine psb_c_set_ncols(n,a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. + integer(psb_ipk_) :: nr call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_ncols(n) + else if (allocated(a%ad)) then + nr = a%get_nrows() + call a%ad%set_ncols(nr) + call a%and%set_ncols(max(0,n-nr)) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_ncols(n) call psb_erractionrestore(err_act) return @@ -129,14 +138,17 @@ subroutine psb_c_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_dupl(n) + else if (allocated(a%ad)) then + call a%ad%set_dupl(n) + call a%and%set_dupl(n) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_dupl(n) - call psb_erractionrestore(err_act) return @@ -161,14 +173,17 @@ subroutine psb_c_set_null(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_null() + else if (allocated(a%ad)) then + call a%ad%set_null() + call a%and%set_null() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_null() - call psb_erractionrestore(err_act) return @@ -189,14 +204,14 @@ subroutine psb_c_set_bld(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_bld + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_bld() - call psb_erractionrestore(err_act) return @@ -218,26 +233,25 @@ subroutine psb_c_set_upd(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_upd() + else if (allocated(a%ad)) then + call a%ad%set_upd() + call a%and%set_upd() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upd() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - - end subroutine psb_c_set_upd - subroutine psb_c_set_asb(a) use psb_c_mat_mod, psb_protect_name => psb_c_set_asb use psb_error_mod @@ -248,18 +262,20 @@ subroutine psb_c_set_asb(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_asb() + else if (allocated(a%ad)) then + call a%ad%set_asb() + call a%and%set_asb() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_asb() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -278,18 +294,20 @@ subroutine psb_c_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_sorted(val) + else if (allocated(a%ad)) then + call a%ad%set_sorted(val) + call a%and%set_sorted(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_sorted(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -308,18 +326,18 @@ subroutine psb_c_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_triangle(val) + else if (allocated(a%ad)) then + call a%ad%set_triangle(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%set_triangle(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -337,18 +355,19 @@ subroutine psb_c_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_symmetric(val) + else if (allocated(a%ad)) then + call a%ad%set_symmetric(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_symmetric(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -366,25 +385,24 @@ subroutine psb_c_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ + if (allocated(a%a)) then + call a%a%set_unit(val) + else if (allocated(a%ad)) then + call a%ad%set_unit(val) + else + call psb_errpush(info,name) goto 9999 endif - - call a%a%set_unit(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_c_set_unit - subroutine psb_c_set_lower(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_lower use psb_error_mod @@ -396,18 +414,19 @@ subroutine psb_c_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_lower(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -426,18 +445,19 @@ subroutine psb_c_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upper(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -457,8 +477,6 @@ end subroutine psb_c_set_upper ! ! ! == =================================== - - subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) use psb_c_mat_mod, psb_protect_name => psb_c_sparse_print use psb_error_mod @@ -473,17 +491,23 @@ subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act, info character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. - + type(psb_c_coo_sparse_mat) :: acoo, ac1,ac2 + info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%print(iout,iv,head,ivr,ivc) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + call acoo%print(iout,iv,head,ivr,ivc) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%print(iout,iv,head,ivr,ivc) - return 9999 call psb_error_handler(err_act) @@ -511,11 +535,7 @@ subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 do inquire(unit=iout, opened=isopen) @@ -529,7 +549,7 @@ subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) end if open(iout,file=fname,iostat=info) if (info == psb_success_) then - call a%a%print(iout,iv,head,ivr,ivc) + call a%print(iout,iv,head,ivr,ivc) close(iout) else write(psb_err_unit,*) 'Error: could not open ',fname,' for output' @@ -543,7 +563,6 @@ subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) end subroutine psb_c_n_sparse_print - subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) use psb_c_mat_mod, psb_protect_name => psb_c_get_neigh use psb_error_mod @@ -555,20 +574,24 @@ subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: lev - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, n1 character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + + if (allocated(a%a)) then + call a%a%get_neigh(idx,neigh,n,info,lev) + else if (allocated(a%ad)) then + call a%ad%get_neigh(idx,neigh,n1,info,lev) + call a%ad%get_neigh(idx,neigh,n,info,lev,nin=n1) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%get_neigh(idx,neigh,n,info,lev) - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -648,14 +671,16 @@ subroutine psb_c_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%reallocate(nz) + else if (allocated(a%ad)) then + call a%ad%reallocate(nz) + call a%and%reallocate(nz) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%reallocate(nz) - return 9999 call psb_error_handler(err_act) @@ -675,6 +700,14 @@ subroutine psb_c_free(a) call a%a%free() deallocate(a%a) endif + if (allocated(a%ad)) then + call a%ad%free() + deallocate(a%ad) + endif + if (allocated(a%and)) then + call a%and%free() + deallocate(a%and) + endif if (allocated(a%rmta)) then call a%rmta%free() deallocate(a%rmta) @@ -694,14 +727,17 @@ subroutine psb_c_trim(a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%trim() + else if (allocated(a%ad)) then + call a%ad%trim() + call a%and%trim() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%trim() - return 9999 call psb_error_handler(err_act) @@ -710,8 +746,6 @@ subroutine psb_c_trim(a) end subroutine psb_c_trim - - subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_mat_mod, psb_protect_name => psb_c_csput_a use psb_c_base_mat_mod @@ -733,15 +767,23 @@ subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_errpush(info,name) goto 9999 endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + + if (allocated(a%a)) then + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else if (allocated(a%ad)) then + call a%ad%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + call a%and%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -774,7 +816,7 @@ subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) endif if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v%v,ja%v%v,val%v%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif @@ -784,14 +826,12 @@ subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_c_csput_v - subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format @@ -811,7 +851,7 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -822,11 +862,24 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& call psb_errpush(info,name) goto 9999 endif + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -860,7 +913,7 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -872,9 +925,23 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale,chksz=chksz) + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + call a%and%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 @@ -889,8 +956,6 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_c_csgetrow - - subroutine psb_c_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) ! Output is always in COO format @@ -936,9 +1001,22 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,& - & rscale=rscale,cscale=cscale) + if (allocated(a%a)) then + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif else info = psb_err_alloc_dealloc_ end if @@ -974,6 +1052,7 @@ subroutine psb_c_tril(a,l,info,diag,imin,imax,& character(len=20) :: name='tril' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_c_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -984,25 +1063,56 @@ subroutine psb_c_tril(a,l,info,diag,imin,imax,& endif allocate(lcoo,stat=info) call l%free() - if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) - call u%free() - if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,ucoo) - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1031,6 +1141,7 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& character(len=20) :: name='triu' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_c_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ @@ -1044,24 +1155,55 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& allocate(ucoo,stat=info) call u%free() - if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) - call l%free() - if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,lcoo) - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1070,7 +1212,6 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& return - end subroutine psb_c_triu @@ -1093,6 +1234,7 @@ subroutine psb_c_csclip(a,b,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat), allocatable :: acoo + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1103,13 +1245,25 @@ subroutine psb_c_csclip(a,b,info,& endif allocate(acoo,stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if call b%free() - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 @@ -1142,6 +1296,7 @@ subroutine psb_c_csclip_ip(a,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat), allocatable :: acoo + type(psb_c_coo_sparse_mat) :: ac1,ac2,aa info = psb_success_ call psb_erractionsave(err_act) @@ -1151,13 +1306,20 @@ subroutine psb_c_csclip_ip(a,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) if (info /= psb_success_) goto 9999 @@ -1190,6 +1352,7 @@ subroutine psb_c_b_csclip(a,b,info,& integer(psb_ipk_) :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1199,8 +1362,19 @@ subroutine psb_c_b_csclip(a,b,info,& goto 9999 endif - call a%a%csclip(b,info,& - & imin,imax,jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1234,36 +1408,39 @@ subroutine psb_c_split_nd(a,n_rows,n_cols,info) info = psb_success_ name = 'psb_split' call psb_erractionsave(err_act) - allocate(aclip) - call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) - allocate(a%ad,mold=a%a) - call a%ad%mv_from_coo(acoo,info) - call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) - if (use_ecsr) then - allocate(andclip) - call andclip%mv_from_coo(acoo,info) - call move_alloc(andclip,a%and) - else - allocate(a%and,mold=a%a) - call a%and%mv_from_coo(acoo,info) + if (allocated(a%a)) then + allocate(aclip) + call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) + allocate(a%ad,mold=a%a) + call a%ad%mv_from_coo(acoo,info) + call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) + if (use_ecsr) then + allocate(andclip) + call andclip%mv_from_coo(acoo,info) + call move_alloc(andclip,a%and) + else + allocate(a%and,mold=a%a) + call a%and%mv_from_coo(acoo,info) + end if + call a%a%free() + deallocate(a%a) end if - if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='cscnv') goto 9999 endif - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) - + return - + end subroutine psb_c_split_nd -subroutine psb_c_merge_nd(a,n_rows,n_cols,info) +subroutine psb_c_merge_nd(a,n_rows,n_cols,info,acoo) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_merge_nd @@ -1271,10 +1448,11 @@ subroutine psb_c_merge_nd(a,n_rows,n_cols,info) class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_c_coo_sparse_mat), intent(out), optional :: acoo !!$ integer(psb_ipk_),optional, intent(in) :: dupl !!$ character(len=*), optional, intent(in) :: type !!$ class(psb_c_base_sparse_mat), intent(in), optional :: mold - type(psb_c_coo_sparse_mat) :: acoo1,acoo2 + type(psb_c_coo_sparse_mat) :: acoo1 integer(psb_ipk_) :: nz logical, parameter :: use_ecsr=.true. character(len=20) :: name, ch_err @@ -1284,19 +1462,21 @@ subroutine psb_c_merge_nd(a,n_rows,n_cols,info) name = 'psb_split' call psb_erractionsave(err_act) - call a%ad%mv_to_coo(acoo1,info) - call acoo1%set_bld() - call acoo1%set_nrows(n_rows) - call acoo1%set_ncols(n_cols) - call a%and%mv_to_coo(acoo2,info) - nz=acoo2%get_nzeros() - call acoo1%csput(nz,acoo2%ia,acoo2%ja,acoo2%val,ione,n_rows,ione,n_cols,info) - if (allocated(a%a)) then - call a%a%free() - deallocate(a%a) + call a%ad%csmerge(a%and,acoo1,n_rows,n_cols,info) + + if (present(acoo)) then + call acoo%mv_from_coo(acoo1,info) + else + call a%ad%free() + call a%and%free() + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + end if + allocate(a%a,mold=a%ad) + call a%a%mv_from_coo(acoo1,info) + deallocate(a%ad,a%and) end if - allocate(a%a,mold=a%ad) - call a%a%mv_from_coo(acoo1,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ @@ -1346,64 +1526,9 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_c_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_c_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_c_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(dupl)) then - call altmp%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call altmp%set_dupl(psb_dupl_def_) - end if - - if (debug) write(psb_err_unit,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - else - call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) - end if - end if + if (allocated(a%a)) call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) call b%trim() call b%set_asb() @@ -1511,65 +1636,25 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) if (a%is_null()) then info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call a%set_dupl(dupl) - else if (a%is_bld()) then - call a%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = psb_err_many_optional_arg_ - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_c_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_c_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_c_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_errpush(info,name) + goto 9999 + endif - if (debug) write(psb_err_unit,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if - call altmp%mv_from_fmt(a%a, info) - call move_alloc(altmp,a%a) - else - call inner_mv_fmt(a%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_mv_fmt(a%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_mv_fmt(a%and,info,type,mold,dupl) - end if + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 end if + + if (allocated(a%a)) call inner_mv_fmt(a%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_mv_fmt(a%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_mv_fmt(a%and,info,type,mold,dupl) if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") @@ -1660,7 +1745,6 @@ contains end subroutine psb_c_cscnv_ip - subroutine psb_c_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod @@ -1676,6 +1760,7 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) integer(psb_ipk_) :: err_act character(len=20) :: name='cscnv' logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1686,7 +1771,18 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) goto 9999 endif - call a%a%cp_to_coo(altmp,info ) + if (allocated(a%a)) then + call a%a%cp_to_coo(altmp,info ) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%cp_to_coo(altmp,info ) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if @@ -1704,7 +1800,6 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1712,7 +1807,6 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) end subroutine psb_c_cscnv_base - subroutine psb_c_clip_d(a,b,info) ! Output is always in COO format use psb_error_mod @@ -1740,7 +1834,7 @@ subroutine psb_c_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info == psb_success_) call a%cp_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1799,7 +1893,7 @@ subroutine psb_c_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info == psb_success_) call a%mv_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1823,7 +1917,6 @@ subroutine psb_c_clip_d_ip(a,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1839,10 +1932,14 @@ subroutine psb_c_mv_from(a,b) class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + logical :: do_split + do_split = allocated(a%ad) + call a%free() allocate(a%a,mold=b, stat=info) call a%a%mv_from_fmt(b,info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) call b%free() return @@ -1859,6 +1956,10 @@ subroutine psb_c_cp_from(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. + logical :: do_split + + do_split = allocated(a%ad) + call psb_erractionsave(err_act) info = psb_success_ @@ -1872,6 +1973,7 @@ subroutine psb_c_cp_from(a,b) allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1892,8 +1994,16 @@ subroutine psb_c_mv_to(a,b) class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 - call b%mv_from_fmt(a%a,info) + if (allocated(a%a)) then + call b%mv_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%mv_from_coo(aa,info) + end if return end subroutine psb_c_mv_to @@ -1907,9 +2017,16 @@ subroutine psb_c_cp_to(a,b) class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 - call b%cp_from_fmt(a%a,info) - + if (allocated(a%a)) then + call b%cp_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%cp_from_coo(aa,info) + end if return end subroutine psb_c_cp_to @@ -1919,7 +2036,11 @@ subroutine psb_c_mold(a,b) class(psb_c_base_sparse_mat), allocatable, intent(out) :: b integer(psb_ipk_) :: info - allocate(b,mold=a%a, stat=info) + if (allocated(a%a)) then + allocate(b,mold=a%a, stat=info) + else if (allocated(a%ad)) then + allocate(b,mold=a%ad, stat=info) + end if end subroutine psb_c_mold @@ -1939,11 +2060,12 @@ subroutine psb_cspmat_type_move(a,b,info) info = psb_success_ call b%free() call move_alloc(a%a,b%a) + call move_alloc(a%ad,b%ad) + call move_alloc(a%and,b%and) return end subroutine psb_cspmat_type_move - subroutine psb_cspmat_clone(a,b,info) use psb_error_mod use psb_string_mod @@ -1963,12 +2085,17 @@ subroutine psb_cspmat_clone(a,b,info) if (allocated(a%a)) then call a%a%clone(b%a,info) end if + if (allocated(a%ad)) then + call a%ad%clone(b%ad,info) + end if + if (allocated(a%and)) then + call a%and%clone(b%and,info) + end if if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1986,6 +2113,7 @@ subroutine psb_c_transp_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -1995,20 +2123,24 @@ subroutine psb_c_transp_1mat(a) goto 9999 endif - call a%a%transp() - + if (allocated(a%a)) then + call a%a%transp() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_c_transp_1mat - - subroutine psb_c_transp_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2020,6 +2152,7 @@ subroutine psb_c_transp_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2029,24 +2162,29 @@ subroutine psb_c_transp_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call b%mv_from(aa) end if - call a%a%transp(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_c_transp_2mat - subroutine psb_c_transc_1mat(a) use psb_error_mod use psb_string_mod @@ -2057,6 +2195,7 @@ subroutine psb_c_transc_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2066,20 +2205,25 @@ subroutine psb_c_transc_1mat(a) goto 9999 endif - call a%a%transc() + if (allocated(a%a)) then + call a%a%transc() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_c_transc_1mat - - subroutine psb_c_transc_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2091,7 +2235,7 @@ subroutine psb_c_transc_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. - + type(psb_c_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) if (a%is_null()) then @@ -2100,24 +2244,29 @@ subroutine psb_c_transc_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call b%mv_from(aa) end if - call a%a%transc(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_c_transc_2mat - subroutine psb_c_asb(a,mold) use psb_c_mat_mod, psb_protect_name => psb_c_asb use psb_error_mod @@ -2137,20 +2286,46 @@ subroutine psb_c_asb(a,mold) goto 9999 endif - call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then - allocate(tmp,mold=mold) - call tmp%mv_from_fmt(a%a,info) - call a%a%free() - call move_alloc(tmp,a%a) + if (allocated(a%a)) then + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_c_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + call a%split_nd(a%get_nrows(),a%get_ncols(),info) + + else if (allocated(a%ad)) then + call a%ad%asb() + call a%and%asb() + if (present(mold)) then + if (.not.same_type_as(a%ad,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%ad,info) + call a%ad%free() + call move_alloc(tmp,a%ad) + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%and,info) + call a%and%free() + call move_alloc(tmp,a%and) + end if + else + mld => psb_c_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) end if else - mld => psb_c_get_base_mat_default() - if (.not.same_type_as(a%a,mld)) & - & call a%cscnv(info) - end if - + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2178,14 +2353,16 @@ subroutine psb_c_reinit(a,clear) call psb_errpush(info,name) goto 9999 endif - - if (a%a%has_update()) then - call a%a%reinit(clear) + if (allocated(a%a)) then + call inner_reinit(a%a,name,info) + else if (allocated(a%ad)) then + call inner_reinit(a%ad,name,info) + call inner_reinit(a%and,name,info) else - info = psb_err_missing_override_method_ + info = psb_err_invalid_mat_state_ call psb_errpush(info,name) - goto 9999 endif + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return @@ -2194,7 +2371,19 @@ subroutine psb_c_reinit(a,clear) 9999 call psb_error_handler(err_act) return - +contains + subroutine inner_reinit(aa,name,info) + class(psb_c_base_sparse_mat) :: aa + character(len=*) :: name + integer(psb_ipk_) :: info + info = 0 + if (aa%has_update()) then + call aa%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + endif + end subroutine inner_reinit end subroutine psb_c_reinit @@ -2212,7 +2401,10 @@ end subroutine psb_c_reinit ! ! ! == =================================== - +! +! +! What do we do here?????? +! subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -2348,7 +2540,15 @@ subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2383,8 +2583,15 @@ subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2430,16 +2637,32 @@ subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then - info = psb_err_invalid_vect_state_ - call psb_errpush(info,name) - goto 9999 - endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + if (allocated(a%a)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if + else if (allocated(a%ad)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) - end if + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 @@ -2473,7 +2696,15 @@ function psb_c_maxval(a) result(res) goto 9999 endif - res = a%a%maxval() + if (allocated(a%a)) then + res = a%a%maxval() + else if (allocated(a%ad)) then + res = max(a%ad%maxval(),a%and%maxval()) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif return @@ -2503,7 +2734,8 @@ function psb_c_csnmi(a) result(res) goto 9999 endif - res = a%a%spnmi() + res = maxval(a%arwsum(info)) + return @@ -2534,9 +2766,9 @@ function psb_c_csnm1(a) result(res) goto 9999 endif - res = a%a%spnm1() - return + res = maxval(a%aclsum(info)) + return 9999 call psb_error_handler(err_act) @@ -2551,7 +2783,7 @@ function psb_c_rowsum(a,info) result(d) use psb_const_mod implicit none class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), allocatable :: d(:) + complex(psb_spk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2567,7 +2799,17 @@ function psb_c_rowsum(a,info) result(d) endif allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%rowsum(d) + if (allocated(a%a)) then + call a%a%rowsum(d) + else if (allocated(a%ad)) then + call a%ad%rowsum(d) + call a%and%rowsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2584,7 +2826,7 @@ function psb_c_arwsum(a,info) result(d) use psb_const_mod implicit none class(psb_cspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2601,7 +2843,17 @@ function psb_c_arwsum(a,info) result(d) allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%arwsum(d) + if (allocated(a%a)) then + call a%a%arwsum(d) + else if (allocated(a%ad)) then + call a%ad%arwsum(d) + call a%and%arwsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2618,7 +2870,7 @@ function psb_c_colsum(a,info) result(d) use psb_const_mod implicit none class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), allocatable :: d(:) + complex(psb_spk_), allocatable :: d(:), d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2635,8 +2887,18 @@ function psb_c_colsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%colsum(d) - + if (allocated(a%a)) then + call a%a%colsum(d) + else if (allocated(a%ad)) then + call a%ad%colsum(d) + call a%and%colsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call psb_erractionrestore(err_act) return @@ -2652,7 +2914,7 @@ function psb_c_aclsum(a,info) result(d) use psb_const_mod implicit none class(psb_cspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2669,7 +2931,17 @@ function psb_c_aclsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%aclsum(d) + if (allocated(a%a)) then + call a%a%aclsum(d) + else if (allocated(a%ad)) then + call a%ad%aclsum(d) + call a%and%aclsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2707,7 +2979,15 @@ function psb_c_get_diag(a,info) result(d) call psb_errpush(info,name) goto 9999 end if - call a%a%get_diag(d,info) + if (allocated(a%a)) then + call a%a%get_diag(d,info) + else if (allocated(a%ad)) then + call a%ad%get_diag(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2742,7 +3022,18 @@ subroutine psb_c_scal(d,a,info,side) goto 9999 endif - call a%a%scal(d,info,side=side) + if (allocated(a%a)) then + call a%a%scal(d,info,side=side) + else if (allocated(a%ad)) then + call a%ad%scal(d,info,side=side) + ! + ! FIXME + ! + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2776,7 +3067,16 @@ subroutine psb_c_scals(d,a,info) goto 9999 endif - call a%a%scal(d,info) + if (allocated(a%a)) then + call a%a%scal(d,info) + else if (allocated(a%ad)) then + call a%ad%scal(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2809,7 +3109,16 @@ subroutine psb_c_scalplusidentity(d,a,info) goto 9999 endif - call a%a%scalpid(d,info) + if (allocated(a%a)) then + call a%a%scalpid(d,info) + else if (allocated(a%ad)) then + call a%ad%scalpid(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,7 +3153,16 @@ subroutine psb_c_spaxpby(alpha,a,beta,b,info) goto 9999 endif - call a%a%spaxpby(alpha,beta,b%a,info) + if (allocated(a%a)) then + call a%a%spaxpby(alpha,beta,b%a,info) + else if (allocated(a%ad)) then + call a%ad%spaxpby(alpha,beta,b%a,info) + call a%and%spaxpby(alpha,cone,b%a,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2856,6 +3174,7 @@ subroutine psb_c_spaxpby(alpha,a,beta,b,info) end subroutine psb_c_spaxpby + function psb_c_cmpval(a,val,tol,info) result(res) use psb_error_mod use psb_const_mod @@ -2880,7 +3199,15 @@ function psb_c_cmpval(a,val,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(val,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(val,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(val,tol,info) .and. a%and%spcmp(val,tol,info) +1 else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2916,7 +3243,15 @@ function psb_c_cmpmat(a,b,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(b%a,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(b%a,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(b%ad,tol,info) .and. a%and%spcmp(b%and,tol,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2939,6 +3274,7 @@ subroutine psb_c_mv_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) @@ -2956,6 +3292,7 @@ subroutine psb_c_cp_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%cp_from_lfmt(b,info) @@ -2970,13 +3307,19 @@ subroutine psb_c_mv_to_lb(a,b) class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_c_coo_sparse_mat) :: acoo if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%mv_to_lfmt(b,info) - call a%free() end if + call a%free() end subroutine psb_c_mv_to_lb @@ -2985,12 +3328,18 @@ subroutine psb_c_cp_to_lb(a,b) use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_to_lb implicit none - class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + type(psb_c_coo_sparse_mat) :: acoo + if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%cp_to_lfmt(b,info) end if diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index e48654ce..1c9a7893 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -64,14 +64,17 @@ subroutine psb_d_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_nrows(m) + else if (allocated(a%ad)) then + call a%ad%set_nrows(m) + call a%and%set_nrows(m) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_nrows(m) - call psb_erractionrestore(err_act) return @@ -91,14 +94,20 @@ subroutine psb_d_set_ncols(n,a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. + integer(psb_ipk_) :: nr call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_ncols(n) + else if (allocated(a%ad)) then + nr = a%get_nrows() + call a%ad%set_ncols(nr) + call a%and%set_ncols(max(0,n-nr)) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_ncols(n) call psb_erractionrestore(err_act) return @@ -129,14 +138,17 @@ subroutine psb_d_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_dupl(n) + else if (allocated(a%ad)) then + call a%ad%set_dupl(n) + call a%and%set_dupl(n) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_dupl(n) - call psb_erractionrestore(err_act) return @@ -161,14 +173,17 @@ subroutine psb_d_set_null(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_null() + else if (allocated(a%ad)) then + call a%ad%set_null() + call a%and%set_null() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_null() - call psb_erractionrestore(err_act) return @@ -189,14 +204,14 @@ subroutine psb_d_set_bld(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_bld + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_bld() - call psb_erractionrestore(err_act) return @@ -218,26 +233,25 @@ subroutine psb_d_set_upd(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_upd() + else if (allocated(a%ad)) then + call a%ad%set_upd() + call a%and%set_upd() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upd() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - - end subroutine psb_d_set_upd - subroutine psb_d_set_asb(a) use psb_d_mat_mod, psb_protect_name => psb_d_set_asb use psb_error_mod @@ -248,18 +262,20 @@ subroutine psb_d_set_asb(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_asb() + else if (allocated(a%ad)) then + call a%ad%set_asb() + call a%and%set_asb() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_asb() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -278,18 +294,20 @@ subroutine psb_d_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_sorted(val) + else if (allocated(a%ad)) then + call a%ad%set_sorted(val) + call a%and%set_sorted(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_sorted(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -308,18 +326,18 @@ subroutine psb_d_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_triangle(val) + else if (allocated(a%ad)) then + call a%ad%set_triangle(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%set_triangle(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -337,18 +355,19 @@ subroutine psb_d_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_symmetric(val) + else if (allocated(a%ad)) then + call a%ad%set_symmetric(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_symmetric(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -366,25 +385,24 @@ subroutine psb_d_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ + if (allocated(a%a)) then + call a%a%set_unit(val) + else if (allocated(a%ad)) then + call a%ad%set_unit(val) + else + call psb_errpush(info,name) goto 9999 endif - - call a%a%set_unit(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_d_set_unit - subroutine psb_d_set_lower(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_lower use psb_error_mod @@ -396,18 +414,19 @@ subroutine psb_d_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_lower(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -426,18 +445,19 @@ subroutine psb_d_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upper(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -457,8 +477,6 @@ end subroutine psb_d_set_upper ! ! ! == =================================== - - subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) use psb_d_mat_mod, psb_protect_name => psb_d_sparse_print use psb_error_mod @@ -473,17 +491,23 @@ subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act, info character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. - + type(psb_d_coo_sparse_mat) :: acoo, ac1,ac2 + info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%print(iout,iv,head,ivr,ivc) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + call acoo%print(iout,iv,head,ivr,ivc) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%print(iout,iv,head,ivr,ivc) - return 9999 call psb_error_handler(err_act) @@ -511,11 +535,7 @@ subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 do inquire(unit=iout, opened=isopen) @@ -529,7 +549,7 @@ subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) end if open(iout,file=fname,iostat=info) if (info == psb_success_) then - call a%a%print(iout,iv,head,ivr,ivc) + call a%print(iout,iv,head,ivr,ivc) close(iout) else write(psb_err_unit,*) 'Error: could not open ',fname,' for output' @@ -543,7 +563,6 @@ subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) end subroutine psb_d_n_sparse_print - subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) use psb_d_mat_mod, psb_protect_name => psb_d_get_neigh use psb_error_mod @@ -555,20 +574,24 @@ subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: lev - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, n1 character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + + if (allocated(a%a)) then + call a%a%get_neigh(idx,neigh,n,info,lev) + else if (allocated(a%ad)) then + call a%ad%get_neigh(idx,neigh,n1,info,lev) + call a%ad%get_neigh(idx,neigh,n,info,lev,nin=n1) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%get_neigh(idx,neigh,n,info,lev) - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -648,14 +671,16 @@ subroutine psb_d_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%reallocate(nz) + else if (allocated(a%ad)) then + call a%ad%reallocate(nz) + call a%and%reallocate(nz) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%reallocate(nz) - return 9999 call psb_error_handler(err_act) @@ -675,6 +700,14 @@ subroutine psb_d_free(a) call a%a%free() deallocate(a%a) endif + if (allocated(a%ad)) then + call a%ad%free() + deallocate(a%ad) + endif + if (allocated(a%and)) then + call a%and%free() + deallocate(a%and) + endif if (allocated(a%rmta)) then call a%rmta%free() deallocate(a%rmta) @@ -694,14 +727,17 @@ subroutine psb_d_trim(a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%trim() + else if (allocated(a%ad)) then + call a%ad%trim() + call a%and%trim() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%trim() - return 9999 call psb_error_handler(err_act) @@ -710,8 +746,6 @@ subroutine psb_d_trim(a) end subroutine psb_d_trim - - subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_mat_mod, psb_protect_name => psb_d_csput_a use psb_d_base_mat_mod @@ -733,15 +767,23 @@ subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_errpush(info,name) goto 9999 endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + + if (allocated(a%a)) then + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else if (allocated(a%ad)) then + call a%ad%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + call a%and%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -774,7 +816,7 @@ subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) endif if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v%v,ja%v%v,val%v%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif @@ -784,14 +826,12 @@ subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_d_csput_v - subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format @@ -811,7 +851,7 @@ subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -822,11 +862,24 @@ subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& call psb_errpush(info,name) goto 9999 endif + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -860,7 +913,7 @@ subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -872,9 +925,23 @@ subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale,chksz=chksz) + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + call a%and%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 @@ -889,8 +956,6 @@ subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_d_csgetrow - - subroutine psb_d_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) ! Output is always in COO format @@ -936,9 +1001,22 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,& - & rscale=rscale,cscale=cscale) + if (allocated(a%a)) then + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif else info = psb_err_alloc_dealloc_ end if @@ -974,6 +1052,7 @@ subroutine psb_d_tril(a,l,info,diag,imin,imax,& character(len=20) :: name='tril' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_d_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -984,25 +1063,56 @@ subroutine psb_d_tril(a,l,info,diag,imin,imax,& endif allocate(lcoo,stat=info) call l%free() - if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) - call u%free() - if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,ucoo) - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1031,6 +1141,7 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& character(len=20) :: name='triu' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_d_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ @@ -1044,24 +1155,55 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& allocate(ucoo,stat=info) call u%free() - if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) - call l%free() - if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,lcoo) - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1070,7 +1212,6 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& return - end subroutine psb_d_triu @@ -1093,6 +1234,7 @@ subroutine psb_d_csclip(a,b,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat), allocatable :: acoo + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1103,13 +1245,25 @@ subroutine psb_d_csclip(a,b,info,& endif allocate(acoo,stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if call b%free() - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 @@ -1142,6 +1296,7 @@ subroutine psb_d_csclip_ip(a,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat), allocatable :: acoo + type(psb_d_coo_sparse_mat) :: ac1,ac2,aa info = psb_success_ call psb_erractionsave(err_act) @@ -1151,13 +1306,20 @@ subroutine psb_d_csclip_ip(a,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) if (info /= psb_success_) goto 9999 @@ -1190,6 +1352,7 @@ subroutine psb_d_b_csclip(a,b,info,& integer(psb_ipk_) :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1199,8 +1362,19 @@ subroutine psb_d_b_csclip(a,b,info,& goto 9999 endif - call a%a%csclip(b,info,& - & imin,imax,jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1234,36 +1408,39 @@ subroutine psb_d_split_nd(a,n_rows,n_cols,info) info = psb_success_ name = 'psb_split' call psb_erractionsave(err_act) - allocate(aclip) - call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) - allocate(a%ad,mold=a%a) - call a%ad%mv_from_coo(acoo,info) - call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) - if (use_ecsr) then - allocate(andclip) - call andclip%mv_from_coo(acoo,info) - call move_alloc(andclip,a%and) - else - allocate(a%and,mold=a%a) - call a%and%mv_from_coo(acoo,info) + if (allocated(a%a)) then + allocate(aclip) + call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) + allocate(a%ad,mold=a%a) + call a%ad%mv_from_coo(acoo,info) + call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) + if (use_ecsr) then + allocate(andclip) + call andclip%mv_from_coo(acoo,info) + call move_alloc(andclip,a%and) + else + allocate(a%and,mold=a%a) + call a%and%mv_from_coo(acoo,info) + end if + call a%a%free() + deallocate(a%a) end if - if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='cscnv') goto 9999 endif - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) - + return - + end subroutine psb_d_split_nd -subroutine psb_d_merge_nd(a,n_rows,n_cols,info) +subroutine psb_d_merge_nd(a,n_rows,n_cols,info,acoo) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_merge_nd @@ -1271,10 +1448,11 @@ subroutine psb_d_merge_nd(a,n_rows,n_cols,info) class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_d_coo_sparse_mat), intent(out), optional :: acoo !!$ integer(psb_ipk_),optional, intent(in) :: dupl !!$ character(len=*), optional, intent(in) :: type !!$ class(psb_d_base_sparse_mat), intent(in), optional :: mold - type(psb_d_coo_sparse_mat) :: acoo1,acoo2 + type(psb_d_coo_sparse_mat) :: acoo1 integer(psb_ipk_) :: nz logical, parameter :: use_ecsr=.true. character(len=20) :: name, ch_err @@ -1284,19 +1462,21 @@ subroutine psb_d_merge_nd(a,n_rows,n_cols,info) name = 'psb_split' call psb_erractionsave(err_act) - call a%ad%mv_to_coo(acoo1,info) - call acoo1%set_bld() - call acoo1%set_nrows(n_rows) - call acoo1%set_ncols(n_cols) - call a%and%mv_to_coo(acoo2,info) - nz=acoo2%get_nzeros() - call acoo1%csput(nz,acoo2%ia,acoo2%ja,acoo2%val,ione,n_rows,ione,n_cols,info) - if (allocated(a%a)) then - call a%a%free() - deallocate(a%a) + call a%ad%csmerge(a%and,acoo1,n_rows,n_cols,info) + + if (present(acoo)) then + call acoo%mv_from_coo(acoo1,info) + else + call a%ad%free() + call a%and%free() + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + end if + allocate(a%a,mold=a%ad) + call a%a%mv_from_coo(acoo1,info) + deallocate(a%ad,a%and) end if - allocate(a%a,mold=a%ad) - call a%a%mv_from_coo(acoo1,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ @@ -1346,64 +1526,9 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_d_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_d_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(dupl)) then - call altmp%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call altmp%set_dupl(psb_dupl_def_) - end if - - if (debug) write(psb_err_unit,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - else - call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) - end if - end if + if (allocated(a%a)) call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) call b%trim() call b%set_asb() @@ -1511,65 +1636,25 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) if (a%is_null()) then info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call a%set_dupl(dupl) - else if (a%is_bld()) then - call a%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = psb_err_many_optional_arg_ - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_d_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_d_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_errpush(info,name) + goto 9999 + endif - if (debug) write(psb_err_unit,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if - call altmp%mv_from_fmt(a%a, info) - call move_alloc(altmp,a%a) - else - call inner_mv_fmt(a%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_mv_fmt(a%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_mv_fmt(a%and,info,type,mold,dupl) - end if + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 end if + + if (allocated(a%a)) call inner_mv_fmt(a%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_mv_fmt(a%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_mv_fmt(a%and,info,type,mold,dupl) if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") @@ -1660,7 +1745,6 @@ contains end subroutine psb_d_cscnv_ip - subroutine psb_d_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod @@ -1676,6 +1760,7 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) integer(psb_ipk_) :: err_act character(len=20) :: name='cscnv' logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1686,7 +1771,18 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) goto 9999 endif - call a%a%cp_to_coo(altmp,info ) + if (allocated(a%a)) then + call a%a%cp_to_coo(altmp,info ) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%cp_to_coo(altmp,info ) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if @@ -1704,7 +1800,6 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1712,7 +1807,6 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) end subroutine psb_d_cscnv_base - subroutine psb_d_clip_d(a,b,info) ! Output is always in COO format use psb_error_mod @@ -1740,7 +1834,7 @@ subroutine psb_d_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info == psb_success_) call a%cp_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1799,7 +1893,7 @@ subroutine psb_d_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info == psb_success_) call a%mv_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1823,7 +1917,6 @@ subroutine psb_d_clip_d_ip(a,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1839,10 +1932,14 @@ subroutine psb_d_mv_from(a,b) class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + logical :: do_split + do_split = allocated(a%ad) + call a%free() allocate(a%a,mold=b, stat=info) call a%a%mv_from_fmt(b,info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) call b%free() return @@ -1859,6 +1956,10 @@ subroutine psb_d_cp_from(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. + logical :: do_split + + do_split = allocated(a%ad) + call psb_erractionsave(err_act) info = psb_success_ @@ -1872,6 +1973,7 @@ subroutine psb_d_cp_from(a,b) allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1892,8 +1994,16 @@ subroutine psb_d_mv_to(a,b) class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 - call b%mv_from_fmt(a%a,info) + if (allocated(a%a)) then + call b%mv_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%mv_from_coo(aa,info) + end if return end subroutine psb_d_mv_to @@ -1907,9 +2017,16 @@ subroutine psb_d_cp_to(a,b) class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 - call b%cp_from_fmt(a%a,info) - + if (allocated(a%a)) then + call b%cp_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%cp_from_coo(aa,info) + end if return end subroutine psb_d_cp_to @@ -1919,7 +2036,11 @@ subroutine psb_d_mold(a,b) class(psb_d_base_sparse_mat), allocatable, intent(out) :: b integer(psb_ipk_) :: info - allocate(b,mold=a%a, stat=info) + if (allocated(a%a)) then + allocate(b,mold=a%a, stat=info) + else if (allocated(a%ad)) then + allocate(b,mold=a%ad, stat=info) + end if end subroutine psb_d_mold @@ -1939,11 +2060,12 @@ subroutine psb_dspmat_type_move(a,b,info) info = psb_success_ call b%free() call move_alloc(a%a,b%a) + call move_alloc(a%ad,b%ad) + call move_alloc(a%and,b%and) return end subroutine psb_dspmat_type_move - subroutine psb_dspmat_clone(a,b,info) use psb_error_mod use psb_string_mod @@ -1963,12 +2085,17 @@ subroutine psb_dspmat_clone(a,b,info) if (allocated(a%a)) then call a%a%clone(b%a,info) end if + if (allocated(a%ad)) then + call a%ad%clone(b%ad,info) + end if + if (allocated(a%and)) then + call a%and%clone(b%and,info) + end if if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1986,6 +2113,7 @@ subroutine psb_d_transp_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -1995,20 +2123,24 @@ subroutine psb_d_transp_1mat(a) goto 9999 endif - call a%a%transp() - + if (allocated(a%a)) then + call a%a%transp() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_d_transp_1mat - - subroutine psb_d_transp_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2020,6 +2152,7 @@ subroutine psb_d_transp_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2029,24 +2162,29 @@ subroutine psb_d_transp_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call b%mv_from(aa) end if - call a%a%transp(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_d_transp_2mat - subroutine psb_d_transc_1mat(a) use psb_error_mod use psb_string_mod @@ -2057,6 +2195,7 @@ subroutine psb_d_transc_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2066,20 +2205,25 @@ subroutine psb_d_transc_1mat(a) goto 9999 endif - call a%a%transc() + if (allocated(a%a)) then + call a%a%transc() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_d_transc_1mat - - subroutine psb_d_transc_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2091,7 +2235,7 @@ subroutine psb_d_transc_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. - + type(psb_d_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) if (a%is_null()) then @@ -2100,24 +2244,29 @@ subroutine psb_d_transc_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call b%mv_from(aa) end if - call a%a%transc(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_d_transc_2mat - subroutine psb_d_asb(a,mold) use psb_d_mat_mod, psb_protect_name => psb_d_asb use psb_error_mod @@ -2137,20 +2286,46 @@ subroutine psb_d_asb(a,mold) goto 9999 endif - call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then - allocate(tmp,mold=mold) - call tmp%mv_from_fmt(a%a,info) - call a%a%free() - call move_alloc(tmp,a%a) + if (allocated(a%a)) then + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_d_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + call a%split_nd(a%get_nrows(),a%get_ncols(),info) + + else if (allocated(a%ad)) then + call a%ad%asb() + call a%and%asb() + if (present(mold)) then + if (.not.same_type_as(a%ad,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%ad,info) + call a%ad%free() + call move_alloc(tmp,a%ad) + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%and,info) + call a%and%free() + call move_alloc(tmp,a%and) + end if + else + mld => psb_d_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) end if else - mld => psb_d_get_base_mat_default() - if (.not.same_type_as(a%a,mld)) & - & call a%cscnv(info) - end if - + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2178,14 +2353,16 @@ subroutine psb_d_reinit(a,clear) call psb_errpush(info,name) goto 9999 endif - - if (a%a%has_update()) then - call a%a%reinit(clear) + if (allocated(a%a)) then + call inner_reinit(a%a,name,info) + else if (allocated(a%ad)) then + call inner_reinit(a%ad,name,info) + call inner_reinit(a%and,name,info) else - info = psb_err_missing_override_method_ + info = psb_err_invalid_mat_state_ call psb_errpush(info,name) - goto 9999 endif + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return @@ -2194,7 +2371,19 @@ subroutine psb_d_reinit(a,clear) 9999 call psb_error_handler(err_act) return - +contains + subroutine inner_reinit(aa,name,info) + class(psb_d_base_sparse_mat) :: aa + character(len=*) :: name + integer(psb_ipk_) :: info + info = 0 + if (aa%has_update()) then + call aa%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + endif + end subroutine inner_reinit end subroutine psb_d_reinit @@ -2212,7 +2401,10 @@ end subroutine psb_d_reinit ! ! ! == =================================== - +! +! +! What do we do here?????? +! subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -2348,7 +2540,15 @@ subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2383,8 +2583,15 @@ subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2430,16 +2637,32 @@ subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then - info = psb_err_invalid_vect_state_ - call psb_errpush(info,name) - goto 9999 - endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + if (allocated(a%a)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if + else if (allocated(a%ad)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) - end if + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 @@ -2473,7 +2696,15 @@ function psb_d_maxval(a) result(res) goto 9999 endif - res = a%a%maxval() + if (allocated(a%a)) then + res = a%a%maxval() + else if (allocated(a%ad)) then + res = max(a%ad%maxval(),a%and%maxval()) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif return @@ -2503,7 +2734,8 @@ function psb_d_csnmi(a) result(res) goto 9999 endif - res = a%a%spnmi() + res = maxval(a%arwsum(info)) + return @@ -2534,9 +2766,9 @@ function psb_d_csnm1(a) result(res) goto 9999 endif - res = a%a%spnm1() - return + res = maxval(a%aclsum(info)) + return 9999 call psb_error_handler(err_act) @@ -2551,7 +2783,7 @@ function psb_d_rowsum(a,info) result(d) use psb_const_mod implicit none class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2567,7 +2799,17 @@ function psb_d_rowsum(a,info) result(d) endif allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%rowsum(d) + if (allocated(a%a)) then + call a%a%rowsum(d) + else if (allocated(a%ad)) then + call a%ad%rowsum(d) + call a%and%rowsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2584,7 +2826,7 @@ function psb_d_arwsum(a,info) result(d) use psb_const_mod implicit none class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2601,7 +2843,17 @@ function psb_d_arwsum(a,info) result(d) allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%arwsum(d) + if (allocated(a%a)) then + call a%a%arwsum(d) + else if (allocated(a%ad)) then + call a%ad%arwsum(d) + call a%and%arwsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2618,7 +2870,7 @@ function psb_d_colsum(a,info) result(d) use psb_const_mod implicit none class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:), d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2635,8 +2887,18 @@ function psb_d_colsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%colsum(d) - + if (allocated(a%a)) then + call a%a%colsum(d) + else if (allocated(a%ad)) then + call a%ad%colsum(d) + call a%and%colsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call psb_erractionrestore(err_act) return @@ -2652,7 +2914,7 @@ function psb_d_aclsum(a,info) result(d) use psb_const_mod implicit none class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2669,7 +2931,17 @@ function psb_d_aclsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%aclsum(d) + if (allocated(a%a)) then + call a%a%aclsum(d) + else if (allocated(a%ad)) then + call a%ad%aclsum(d) + call a%and%aclsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2707,7 +2979,15 @@ function psb_d_get_diag(a,info) result(d) call psb_errpush(info,name) goto 9999 end if - call a%a%get_diag(d,info) + if (allocated(a%a)) then + call a%a%get_diag(d,info) + else if (allocated(a%ad)) then + call a%ad%get_diag(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2742,7 +3022,18 @@ subroutine psb_d_scal(d,a,info,side) goto 9999 endif - call a%a%scal(d,info,side=side) + if (allocated(a%a)) then + call a%a%scal(d,info,side=side) + else if (allocated(a%ad)) then + call a%ad%scal(d,info,side=side) + ! + ! FIXME + ! + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2776,7 +3067,16 @@ subroutine psb_d_scals(d,a,info) goto 9999 endif - call a%a%scal(d,info) + if (allocated(a%a)) then + call a%a%scal(d,info) + else if (allocated(a%ad)) then + call a%ad%scal(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2809,7 +3109,16 @@ subroutine psb_d_scalplusidentity(d,a,info) goto 9999 endif - call a%a%scalpid(d,info) + if (allocated(a%a)) then + call a%a%scalpid(d,info) + else if (allocated(a%ad)) then + call a%ad%scalpid(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,7 +3153,16 @@ subroutine psb_d_spaxpby(alpha,a,beta,b,info) goto 9999 endif - call a%a%spaxpby(alpha,beta,b%a,info) + if (allocated(a%a)) then + call a%a%spaxpby(alpha,beta,b%a,info) + else if (allocated(a%ad)) then + call a%ad%spaxpby(alpha,beta,b%a,info) + call a%and%spaxpby(alpha,done,b%a,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2856,6 +3174,7 @@ subroutine psb_d_spaxpby(alpha,a,beta,b,info) end subroutine psb_d_spaxpby + function psb_d_cmpval(a,val,tol,info) result(res) use psb_error_mod use psb_const_mod @@ -2880,7 +3199,15 @@ function psb_d_cmpval(a,val,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(val,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(val,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(val,tol,info) .and. a%and%spcmp(val,tol,info) +1 else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2916,7 +3243,15 @@ function psb_d_cmpmat(a,b,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(b%a,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(b%a,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(b%ad,tol,info) .and. a%and%spcmp(b%and,tol,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2939,6 +3274,7 @@ subroutine psb_d_mv_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) @@ -2956,6 +3292,7 @@ subroutine psb_d_cp_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%cp_from_lfmt(b,info) @@ -2970,13 +3307,19 @@ subroutine psb_d_mv_to_lb(a,b) class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_d_coo_sparse_mat) :: acoo if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%mv_to_lfmt(b,info) - call a%free() end if + call a%free() end subroutine psb_d_mv_to_lb @@ -2985,12 +3328,18 @@ subroutine psb_d_cp_to_lb(a,b) use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_to_lb implicit none - class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + type(psb_d_coo_sparse_mat) :: acoo + if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%cp_to_lfmt(b,info) end if diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 77ac81e6..ca78bab0 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -64,14 +64,17 @@ subroutine psb_s_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_nrows(m) + else if (allocated(a%ad)) then + call a%ad%set_nrows(m) + call a%and%set_nrows(m) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_nrows(m) - call psb_erractionrestore(err_act) return @@ -91,14 +94,20 @@ subroutine psb_s_set_ncols(n,a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. + integer(psb_ipk_) :: nr call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_ncols(n) + else if (allocated(a%ad)) then + nr = a%get_nrows() + call a%ad%set_ncols(nr) + call a%and%set_ncols(max(0,n-nr)) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_ncols(n) call psb_erractionrestore(err_act) return @@ -129,14 +138,17 @@ subroutine psb_s_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_dupl(n) + else if (allocated(a%ad)) then + call a%ad%set_dupl(n) + call a%and%set_dupl(n) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_dupl(n) - call psb_erractionrestore(err_act) return @@ -161,14 +173,17 @@ subroutine psb_s_set_null(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_null() + else if (allocated(a%ad)) then + call a%ad%set_null() + call a%and%set_null() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_null() - call psb_erractionrestore(err_act) return @@ -189,14 +204,14 @@ subroutine psb_s_set_bld(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_bld + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_bld() - call psb_erractionrestore(err_act) return @@ -218,26 +233,25 @@ subroutine psb_s_set_upd(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_upd() + else if (allocated(a%ad)) then + call a%ad%set_upd() + call a%and%set_upd() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upd() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - - end subroutine psb_s_set_upd - subroutine psb_s_set_asb(a) use psb_s_mat_mod, psb_protect_name => psb_s_set_asb use psb_error_mod @@ -248,18 +262,20 @@ subroutine psb_s_set_asb(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_asb() + else if (allocated(a%ad)) then + call a%ad%set_asb() + call a%and%set_asb() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_asb() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -278,18 +294,20 @@ subroutine psb_s_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_sorted(val) + else if (allocated(a%ad)) then + call a%ad%set_sorted(val) + call a%and%set_sorted(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_sorted(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -308,18 +326,18 @@ subroutine psb_s_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_triangle(val) + else if (allocated(a%ad)) then + call a%ad%set_triangle(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%set_triangle(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -337,18 +355,19 @@ subroutine psb_s_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_symmetric(val) + else if (allocated(a%ad)) then + call a%ad%set_symmetric(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_symmetric(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -366,25 +385,24 @@ subroutine psb_s_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ + if (allocated(a%a)) then + call a%a%set_unit(val) + else if (allocated(a%ad)) then + call a%ad%set_unit(val) + else + call psb_errpush(info,name) goto 9999 endif - - call a%a%set_unit(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_s_set_unit - subroutine psb_s_set_lower(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_lower use psb_error_mod @@ -396,18 +414,19 @@ subroutine psb_s_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_lower(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -426,18 +445,19 @@ subroutine psb_s_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upper(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -457,8 +477,6 @@ end subroutine psb_s_set_upper ! ! ! == =================================== - - subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) use psb_s_mat_mod, psb_protect_name => psb_s_sparse_print use psb_error_mod @@ -473,17 +491,23 @@ subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act, info character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. - + type(psb_s_coo_sparse_mat) :: acoo, ac1,ac2 + info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%print(iout,iv,head,ivr,ivc) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + call acoo%print(iout,iv,head,ivr,ivc) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%print(iout,iv,head,ivr,ivc) - return 9999 call psb_error_handler(err_act) @@ -511,11 +535,7 @@ subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 do inquire(unit=iout, opened=isopen) @@ -529,7 +549,7 @@ subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) end if open(iout,file=fname,iostat=info) if (info == psb_success_) then - call a%a%print(iout,iv,head,ivr,ivc) + call a%print(iout,iv,head,ivr,ivc) close(iout) else write(psb_err_unit,*) 'Error: could not open ',fname,' for output' @@ -543,7 +563,6 @@ subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) end subroutine psb_s_n_sparse_print - subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) use psb_s_mat_mod, psb_protect_name => psb_s_get_neigh use psb_error_mod @@ -555,20 +574,24 @@ subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: lev - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, n1 character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + + if (allocated(a%a)) then + call a%a%get_neigh(idx,neigh,n,info,lev) + else if (allocated(a%ad)) then + call a%ad%get_neigh(idx,neigh,n1,info,lev) + call a%ad%get_neigh(idx,neigh,n,info,lev,nin=n1) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%get_neigh(idx,neigh,n,info,lev) - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -648,14 +671,16 @@ subroutine psb_s_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%reallocate(nz) + else if (allocated(a%ad)) then + call a%ad%reallocate(nz) + call a%and%reallocate(nz) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%reallocate(nz) - return 9999 call psb_error_handler(err_act) @@ -675,6 +700,14 @@ subroutine psb_s_free(a) call a%a%free() deallocate(a%a) endif + if (allocated(a%ad)) then + call a%ad%free() + deallocate(a%ad) + endif + if (allocated(a%and)) then + call a%and%free() + deallocate(a%and) + endif if (allocated(a%rmta)) then call a%rmta%free() deallocate(a%rmta) @@ -694,14 +727,17 @@ subroutine psb_s_trim(a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%trim() + else if (allocated(a%ad)) then + call a%ad%trim() + call a%and%trim() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%trim() - return 9999 call psb_error_handler(err_act) @@ -710,8 +746,6 @@ subroutine psb_s_trim(a) end subroutine psb_s_trim - - subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_mat_mod, psb_protect_name => psb_s_csput_a use psb_s_base_mat_mod @@ -733,15 +767,23 @@ subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_errpush(info,name) goto 9999 endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + + if (allocated(a%a)) then + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else if (allocated(a%ad)) then + call a%ad%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + call a%and%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -774,7 +816,7 @@ subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) endif if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v%v,ja%v%v,val%v%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif @@ -784,14 +826,12 @@ subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_s_csput_v - subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format @@ -811,7 +851,7 @@ subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -822,11 +862,24 @@ subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& call psb_errpush(info,name) goto 9999 endif + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -860,7 +913,7 @@ subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -872,9 +925,23 @@ subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale,chksz=chksz) + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + call a%and%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 @@ -889,8 +956,6 @@ subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_s_csgetrow - - subroutine psb_s_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) ! Output is always in COO format @@ -936,9 +1001,22 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,& - & rscale=rscale,cscale=cscale) + if (allocated(a%a)) then + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif else info = psb_err_alloc_dealloc_ end if @@ -974,6 +1052,7 @@ subroutine psb_s_tril(a,l,info,diag,imin,imax,& character(len=20) :: name='tril' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_s_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -984,25 +1063,56 @@ subroutine psb_s_tril(a,l,info,diag,imin,imax,& endif allocate(lcoo,stat=info) call l%free() - if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) - call u%free() - if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,ucoo) - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1031,6 +1141,7 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& character(len=20) :: name='triu' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_s_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ @@ -1044,24 +1155,55 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& allocate(ucoo,stat=info) call u%free() - if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) - call l%free() - if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,lcoo) - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1070,7 +1212,6 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& return - end subroutine psb_s_triu @@ -1093,6 +1234,7 @@ subroutine psb_s_csclip(a,b,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat), allocatable :: acoo + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1103,13 +1245,25 @@ subroutine psb_s_csclip(a,b,info,& endif allocate(acoo,stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if call b%free() - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 @@ -1142,6 +1296,7 @@ subroutine psb_s_csclip_ip(a,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat), allocatable :: acoo + type(psb_s_coo_sparse_mat) :: ac1,ac2,aa info = psb_success_ call psb_erractionsave(err_act) @@ -1151,13 +1306,20 @@ subroutine psb_s_csclip_ip(a,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) if (info /= psb_success_) goto 9999 @@ -1190,6 +1352,7 @@ subroutine psb_s_b_csclip(a,b,info,& integer(psb_ipk_) :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1199,8 +1362,19 @@ subroutine psb_s_b_csclip(a,b,info,& goto 9999 endif - call a%a%csclip(b,info,& - & imin,imax,jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1234,36 +1408,39 @@ subroutine psb_s_split_nd(a,n_rows,n_cols,info) info = psb_success_ name = 'psb_split' call psb_erractionsave(err_act) - allocate(aclip) - call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) - allocate(a%ad,mold=a%a) - call a%ad%mv_from_coo(acoo,info) - call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) - if (use_ecsr) then - allocate(andclip) - call andclip%mv_from_coo(acoo,info) - call move_alloc(andclip,a%and) - else - allocate(a%and,mold=a%a) - call a%and%mv_from_coo(acoo,info) + if (allocated(a%a)) then + allocate(aclip) + call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) + allocate(a%ad,mold=a%a) + call a%ad%mv_from_coo(acoo,info) + call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) + if (use_ecsr) then + allocate(andclip) + call andclip%mv_from_coo(acoo,info) + call move_alloc(andclip,a%and) + else + allocate(a%and,mold=a%a) + call a%and%mv_from_coo(acoo,info) + end if + call a%a%free() + deallocate(a%a) end if - if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='cscnv') goto 9999 endif - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) - + return - + end subroutine psb_s_split_nd -subroutine psb_s_merge_nd(a,n_rows,n_cols,info) +subroutine psb_s_merge_nd(a,n_rows,n_cols,info,acoo) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_merge_nd @@ -1271,10 +1448,11 @@ subroutine psb_s_merge_nd(a,n_rows,n_cols,info) class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_s_coo_sparse_mat), intent(out), optional :: acoo !!$ integer(psb_ipk_),optional, intent(in) :: dupl !!$ character(len=*), optional, intent(in) :: type !!$ class(psb_s_base_sparse_mat), intent(in), optional :: mold - type(psb_s_coo_sparse_mat) :: acoo1,acoo2 + type(psb_s_coo_sparse_mat) :: acoo1 integer(psb_ipk_) :: nz logical, parameter :: use_ecsr=.true. character(len=20) :: name, ch_err @@ -1284,19 +1462,21 @@ subroutine psb_s_merge_nd(a,n_rows,n_cols,info) name = 'psb_split' call psb_erractionsave(err_act) - call a%ad%mv_to_coo(acoo1,info) - call acoo1%set_bld() - call acoo1%set_nrows(n_rows) - call acoo1%set_ncols(n_cols) - call a%and%mv_to_coo(acoo2,info) - nz=acoo2%get_nzeros() - call acoo1%csput(nz,acoo2%ia,acoo2%ja,acoo2%val,ione,n_rows,ione,n_cols,info) - if (allocated(a%a)) then - call a%a%free() - deallocate(a%a) + call a%ad%csmerge(a%and,acoo1,n_rows,n_cols,info) + + if (present(acoo)) then + call acoo%mv_from_coo(acoo1,info) + else + call a%ad%free() + call a%and%free() + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + end if + allocate(a%a,mold=a%ad) + call a%a%mv_from_coo(acoo1,info) + deallocate(a%ad,a%and) end if - allocate(a%a,mold=a%ad) - call a%a%mv_from_coo(acoo1,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ @@ -1346,64 +1526,9 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_s_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_s_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_s_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(dupl)) then - call altmp%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call altmp%set_dupl(psb_dupl_def_) - end if - - if (debug) write(psb_err_unit,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - else - call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) - end if - end if + if (allocated(a%a)) call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) call b%trim() call b%set_asb() @@ -1511,65 +1636,25 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) if (a%is_null()) then info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call a%set_dupl(dupl) - else if (a%is_bld()) then - call a%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = psb_err_many_optional_arg_ - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_s_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_s_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_s_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_errpush(info,name) + goto 9999 + endif - if (debug) write(psb_err_unit,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if - call altmp%mv_from_fmt(a%a, info) - call move_alloc(altmp,a%a) - else - call inner_mv_fmt(a%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_mv_fmt(a%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_mv_fmt(a%and,info,type,mold,dupl) - end if + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 end if + + if (allocated(a%a)) call inner_mv_fmt(a%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_mv_fmt(a%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_mv_fmt(a%and,info,type,mold,dupl) if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") @@ -1660,7 +1745,6 @@ contains end subroutine psb_s_cscnv_ip - subroutine psb_s_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod @@ -1676,6 +1760,7 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) integer(psb_ipk_) :: err_act character(len=20) :: name='cscnv' logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1686,7 +1771,18 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) goto 9999 endif - call a%a%cp_to_coo(altmp,info ) + if (allocated(a%a)) then + call a%a%cp_to_coo(altmp,info ) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%cp_to_coo(altmp,info ) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if @@ -1704,7 +1800,6 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1712,7 +1807,6 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) end subroutine psb_s_cscnv_base - subroutine psb_s_clip_d(a,b,info) ! Output is always in COO format use psb_error_mod @@ -1740,7 +1834,7 @@ subroutine psb_s_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info == psb_success_) call a%cp_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1799,7 +1893,7 @@ subroutine psb_s_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info == psb_success_) call a%mv_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1823,7 +1917,6 @@ subroutine psb_s_clip_d_ip(a,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1839,10 +1932,14 @@ subroutine psb_s_mv_from(a,b) class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + logical :: do_split + do_split = allocated(a%ad) + call a%free() allocate(a%a,mold=b, stat=info) call a%a%mv_from_fmt(b,info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) call b%free() return @@ -1859,6 +1956,10 @@ subroutine psb_s_cp_from(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. + logical :: do_split + + do_split = allocated(a%ad) + call psb_erractionsave(err_act) info = psb_success_ @@ -1872,6 +1973,7 @@ subroutine psb_s_cp_from(a,b) allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1892,8 +1994,16 @@ subroutine psb_s_mv_to(a,b) class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 - call b%mv_from_fmt(a%a,info) + if (allocated(a%a)) then + call b%mv_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%mv_from_coo(aa,info) + end if return end subroutine psb_s_mv_to @@ -1907,9 +2017,16 @@ subroutine psb_s_cp_to(a,b) class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 - call b%cp_from_fmt(a%a,info) - + if (allocated(a%a)) then + call b%cp_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%cp_from_coo(aa,info) + end if return end subroutine psb_s_cp_to @@ -1919,7 +2036,11 @@ subroutine psb_s_mold(a,b) class(psb_s_base_sparse_mat), allocatable, intent(out) :: b integer(psb_ipk_) :: info - allocate(b,mold=a%a, stat=info) + if (allocated(a%a)) then + allocate(b,mold=a%a, stat=info) + else if (allocated(a%ad)) then + allocate(b,mold=a%ad, stat=info) + end if end subroutine psb_s_mold @@ -1939,11 +2060,12 @@ subroutine psb_sspmat_type_move(a,b,info) info = psb_success_ call b%free() call move_alloc(a%a,b%a) + call move_alloc(a%ad,b%ad) + call move_alloc(a%and,b%and) return end subroutine psb_sspmat_type_move - subroutine psb_sspmat_clone(a,b,info) use psb_error_mod use psb_string_mod @@ -1963,12 +2085,17 @@ subroutine psb_sspmat_clone(a,b,info) if (allocated(a%a)) then call a%a%clone(b%a,info) end if + if (allocated(a%ad)) then + call a%ad%clone(b%ad,info) + end if + if (allocated(a%and)) then + call a%and%clone(b%and,info) + end if if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1986,6 +2113,7 @@ subroutine psb_s_transp_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -1995,20 +2123,24 @@ subroutine psb_s_transp_1mat(a) goto 9999 endif - call a%a%transp() - + if (allocated(a%a)) then + call a%a%transp() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_s_transp_1mat - - subroutine psb_s_transp_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2020,6 +2152,7 @@ subroutine psb_s_transp_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2029,24 +2162,29 @@ subroutine psb_s_transp_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call b%mv_from(aa) end if - call a%a%transp(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_s_transp_2mat - subroutine psb_s_transc_1mat(a) use psb_error_mod use psb_string_mod @@ -2057,6 +2195,7 @@ subroutine psb_s_transc_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2066,20 +2205,25 @@ subroutine psb_s_transc_1mat(a) goto 9999 endif - call a%a%transc() + if (allocated(a%a)) then + call a%a%transc() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_s_transc_1mat - - subroutine psb_s_transc_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2091,7 +2235,7 @@ subroutine psb_s_transc_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. - + type(psb_s_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) if (a%is_null()) then @@ -2100,24 +2244,29 @@ subroutine psb_s_transc_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call b%mv_from(aa) end if - call a%a%transc(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_s_transc_2mat - subroutine psb_s_asb(a,mold) use psb_s_mat_mod, psb_protect_name => psb_s_asb use psb_error_mod @@ -2137,20 +2286,46 @@ subroutine psb_s_asb(a,mold) goto 9999 endif - call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then - allocate(tmp,mold=mold) - call tmp%mv_from_fmt(a%a,info) - call a%a%free() - call move_alloc(tmp,a%a) + if (allocated(a%a)) then + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_s_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + call a%split_nd(a%get_nrows(),a%get_ncols(),info) + + else if (allocated(a%ad)) then + call a%ad%asb() + call a%and%asb() + if (present(mold)) then + if (.not.same_type_as(a%ad,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%ad,info) + call a%ad%free() + call move_alloc(tmp,a%ad) + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%and,info) + call a%and%free() + call move_alloc(tmp,a%and) + end if + else + mld => psb_s_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) end if else - mld => psb_s_get_base_mat_default() - if (.not.same_type_as(a%a,mld)) & - & call a%cscnv(info) - end if - + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2178,14 +2353,16 @@ subroutine psb_s_reinit(a,clear) call psb_errpush(info,name) goto 9999 endif - - if (a%a%has_update()) then - call a%a%reinit(clear) + if (allocated(a%a)) then + call inner_reinit(a%a,name,info) + else if (allocated(a%ad)) then + call inner_reinit(a%ad,name,info) + call inner_reinit(a%and,name,info) else - info = psb_err_missing_override_method_ + info = psb_err_invalid_mat_state_ call psb_errpush(info,name) - goto 9999 endif + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return @@ -2194,7 +2371,19 @@ subroutine psb_s_reinit(a,clear) 9999 call psb_error_handler(err_act) return - +contains + subroutine inner_reinit(aa,name,info) + class(psb_s_base_sparse_mat) :: aa + character(len=*) :: name + integer(psb_ipk_) :: info + info = 0 + if (aa%has_update()) then + call aa%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + endif + end subroutine inner_reinit end subroutine psb_s_reinit @@ -2212,7 +2401,10 @@ end subroutine psb_s_reinit ! ! ! == =================================== - +! +! +! What do we do here?????? +! subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -2348,7 +2540,15 @@ subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2383,8 +2583,15 @@ subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2430,16 +2637,32 @@ subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then - info = psb_err_invalid_vect_state_ - call psb_errpush(info,name) - goto 9999 - endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + if (allocated(a%a)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if + else if (allocated(a%ad)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) - end if + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 @@ -2473,7 +2696,15 @@ function psb_s_maxval(a) result(res) goto 9999 endif - res = a%a%maxval() + if (allocated(a%a)) then + res = a%a%maxval() + else if (allocated(a%ad)) then + res = max(a%ad%maxval(),a%and%maxval()) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif return @@ -2503,7 +2734,8 @@ function psb_s_csnmi(a) result(res) goto 9999 endif - res = a%a%spnmi() + res = maxval(a%arwsum(info)) + return @@ -2534,9 +2766,9 @@ function psb_s_csnm1(a) result(res) goto 9999 endif - res = a%a%spnm1() - return + res = maxval(a%aclsum(info)) + return 9999 call psb_error_handler(err_act) @@ -2551,7 +2783,7 @@ function psb_s_rowsum(a,info) result(d) use psb_const_mod implicit none class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2567,7 +2799,17 @@ function psb_s_rowsum(a,info) result(d) endif allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%rowsum(d) + if (allocated(a%a)) then + call a%a%rowsum(d) + else if (allocated(a%ad)) then + call a%ad%rowsum(d) + call a%and%rowsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2584,7 +2826,7 @@ function psb_s_arwsum(a,info) result(d) use psb_const_mod implicit none class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2601,7 +2843,17 @@ function psb_s_arwsum(a,info) result(d) allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%arwsum(d) + if (allocated(a%a)) then + call a%a%arwsum(d) + else if (allocated(a%ad)) then + call a%ad%arwsum(d) + call a%and%arwsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2618,7 +2870,7 @@ function psb_s_colsum(a,info) result(d) use psb_const_mod implicit none class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:), d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2635,8 +2887,18 @@ function psb_s_colsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%colsum(d) - + if (allocated(a%a)) then + call a%a%colsum(d) + else if (allocated(a%ad)) then + call a%ad%colsum(d) + call a%and%colsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call psb_erractionrestore(err_act) return @@ -2652,7 +2914,7 @@ function psb_s_aclsum(a,info) result(d) use psb_const_mod implicit none class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) + real(psb_spk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2669,7 +2931,17 @@ function psb_s_aclsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%aclsum(d) + if (allocated(a%a)) then + call a%a%aclsum(d) + else if (allocated(a%ad)) then + call a%ad%aclsum(d) + call a%and%aclsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2707,7 +2979,15 @@ function psb_s_get_diag(a,info) result(d) call psb_errpush(info,name) goto 9999 end if - call a%a%get_diag(d,info) + if (allocated(a%a)) then + call a%a%get_diag(d,info) + else if (allocated(a%ad)) then + call a%ad%get_diag(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2742,7 +3022,18 @@ subroutine psb_s_scal(d,a,info,side) goto 9999 endif - call a%a%scal(d,info,side=side) + if (allocated(a%a)) then + call a%a%scal(d,info,side=side) + else if (allocated(a%ad)) then + call a%ad%scal(d,info,side=side) + ! + ! FIXME + ! + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2776,7 +3067,16 @@ subroutine psb_s_scals(d,a,info) goto 9999 endif - call a%a%scal(d,info) + if (allocated(a%a)) then + call a%a%scal(d,info) + else if (allocated(a%ad)) then + call a%ad%scal(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2809,7 +3109,16 @@ subroutine psb_s_scalplusidentity(d,a,info) goto 9999 endif - call a%a%scalpid(d,info) + if (allocated(a%a)) then + call a%a%scalpid(d,info) + else if (allocated(a%ad)) then + call a%ad%scalpid(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,7 +3153,16 @@ subroutine psb_s_spaxpby(alpha,a,beta,b,info) goto 9999 endif - call a%a%spaxpby(alpha,beta,b%a,info) + if (allocated(a%a)) then + call a%a%spaxpby(alpha,beta,b%a,info) + else if (allocated(a%ad)) then + call a%ad%spaxpby(alpha,beta,b%a,info) + call a%and%spaxpby(alpha,sone,b%a,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2856,6 +3174,7 @@ subroutine psb_s_spaxpby(alpha,a,beta,b,info) end subroutine psb_s_spaxpby + function psb_s_cmpval(a,val,tol,info) result(res) use psb_error_mod use psb_const_mod @@ -2880,7 +3199,15 @@ function psb_s_cmpval(a,val,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(val,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(val,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(val,tol,info) .and. a%and%spcmp(val,tol,info) +1 else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2916,7 +3243,15 @@ function psb_s_cmpmat(a,b,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(b%a,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(b%a,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(b%ad,tol,info) .and. a%and%spcmp(b%and,tol,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2939,6 +3274,7 @@ subroutine psb_s_mv_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) @@ -2956,6 +3292,7 @@ subroutine psb_s_cp_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%cp_from_lfmt(b,info) @@ -2970,13 +3307,19 @@ subroutine psb_s_mv_to_lb(a,b) class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_s_coo_sparse_mat) :: acoo if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%mv_to_lfmt(b,info) - call a%free() end if + call a%free() end subroutine psb_s_mv_to_lb @@ -2985,12 +3328,18 @@ subroutine psb_s_cp_to_lb(a,b) use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_to_lb implicit none - class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + type(psb_s_coo_sparse_mat) :: acoo + if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%cp_to_lfmt(b,info) end if diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index 18d6c03d..dc074c14 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -64,14 +64,17 @@ subroutine psb_z_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_nrows(m) + else if (allocated(a%ad)) then + call a%ad%set_nrows(m) + call a%and%set_nrows(m) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_nrows(m) - call psb_erractionrestore(err_act) return @@ -91,14 +94,20 @@ subroutine psb_z_set_ncols(n,a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. + integer(psb_ipk_) :: nr call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_ncols(n) + else if (allocated(a%ad)) then + nr = a%get_nrows() + call a%ad%set_ncols(nr) + call a%and%set_ncols(max(0,n-nr)) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_ncols(n) call psb_erractionrestore(err_act) return @@ -129,14 +138,17 @@ subroutine psb_z_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_dupl(n) + else if (allocated(a%ad)) then + call a%ad%set_dupl(n) + call a%and%set_dupl(n) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_dupl(n) - call psb_erractionrestore(err_act) return @@ -161,14 +173,17 @@ subroutine psb_z_set_null(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_null() + else if (allocated(a%ad)) then + call a%ad%set_null() + call a%and%set_null() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_null() - call psb_erractionrestore(err_act) return @@ -189,14 +204,14 @@ subroutine psb_z_set_bld(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_bld + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_bld() - call psb_erractionrestore(err_act) return @@ -218,26 +233,25 @@ subroutine psb_z_set_upd(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_upd() + else if (allocated(a%ad)) then + call a%ad%set_upd() + call a%and%set_upd() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upd() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - - end subroutine psb_z_set_upd - subroutine psb_z_set_asb(a) use psb_z_mat_mod, psb_protect_name => psb_z_set_asb use psb_error_mod @@ -248,18 +262,20 @@ subroutine psb_z_set_asb(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_asb() + else if (allocated(a%ad)) then + call a%ad%set_asb() + call a%and%set_asb() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_asb() - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -278,18 +294,20 @@ subroutine psb_z_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_sorted(val) + else if (allocated(a%ad)) then + call a%ad%set_sorted(val) + call a%and%set_sorted(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_sorted(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -308,18 +326,18 @@ subroutine psb_z_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_triangle(val) + else if (allocated(a%ad)) then + call a%ad%set_triangle(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%set_triangle(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -337,18 +355,19 @@ subroutine psb_z_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_symmetric(val) + else if (allocated(a%ad)) then + call a%ad%set_symmetric(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_symmetric(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -366,25 +385,24 @@ subroutine psb_z_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ + if (allocated(a%a)) then + call a%a%set_unit(val) + else if (allocated(a%ad)) then + call a%ad%set_unit(val) + else + call psb_errpush(info,name) goto 9999 endif - - call a%a%set_unit(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_z_set_unit - subroutine psb_z_set_lower(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_lower use psb_error_mod @@ -396,18 +414,19 @@ subroutine psb_z_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_lower(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -426,18 +445,19 @@ subroutine psb_z_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%set_lower(val) + else if (allocated(a%ad)) then + call a%ad%set_lower(val) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%set_upper(val) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -457,8 +477,6 @@ end subroutine psb_z_set_upper ! ! ! == =================================== - - subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) use psb_z_mat_mod, psb_protect_name => psb_z_sparse_print use psb_error_mod @@ -473,17 +491,23 @@ subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act, info character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. - + type(psb_z_coo_sparse_mat) :: acoo, ac1,ac2 + info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%print(iout,iv,head,ivr,ivc) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + call acoo%print(iout,iv,head,ivr,ivc) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%print(iout,iv,head,ivr,ivc) - return 9999 call psb_error_handler(err_act) @@ -511,11 +535,7 @@ subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 do inquire(unit=iout, opened=isopen) @@ -529,7 +549,7 @@ subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) end if open(iout,file=fname,iostat=info) if (info == psb_success_) then - call a%a%print(iout,iv,head,ivr,ivc) + call a%print(iout,iv,head,ivr,ivc) close(iout) else write(psb_err_unit,*) 'Error: could not open ',fname,' for output' @@ -543,7 +563,6 @@ subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) end subroutine psb_z_n_sparse_print - subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) use psb_z_mat_mod, psb_protect_name => psb_z_get_neigh use psb_error_mod @@ -555,20 +574,24 @@ subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: lev - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, n1 character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + + if (allocated(a%a)) then + call a%a%get_neigh(idx,neigh,n,info,lev) + else if (allocated(a%ad)) then + call a%ad%get_neigh(idx,neigh,n1,info,lev) + call a%ad%get_neigh(idx,neigh,n,info,lev,nin=n1) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%get_neigh(idx,neigh,n,info,lev) - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -648,14 +671,16 @@ subroutine psb_z_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%reallocate(nz) + else if (allocated(a%ad)) then + call a%ad%reallocate(nz) + call a%and%reallocate(nz) + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - - call a%a%reallocate(nz) - return 9999 call psb_error_handler(err_act) @@ -675,6 +700,14 @@ subroutine psb_z_free(a) call a%a%free() deallocate(a%a) endif + if (allocated(a%ad)) then + call a%ad%free() + deallocate(a%ad) + endif + if (allocated(a%and)) then + call a%and%free() + deallocate(a%and) + endif if (allocated(a%rmta)) then call a%rmta%free() deallocate(a%rmta) @@ -694,14 +727,17 @@ subroutine psb_z_trim(a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (allocated(a%a)) then + call a%a%trim() + else if (allocated(a%ad)) then + call a%ad%trim() + call a%and%trim() + else info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%trim() - return 9999 call psb_error_handler(err_act) @@ -710,8 +746,6 @@ subroutine psb_z_trim(a) end subroutine psb_z_trim - - subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_mat_mod, psb_protect_name => psb_z_csput_a use psb_z_base_mat_mod @@ -733,15 +767,23 @@ subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_errpush(info,name) goto 9999 endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + + if (allocated(a%a)) then + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else if (allocated(a%ad)) then + call a%ad%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + call a%and%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -774,7 +816,7 @@ subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) endif if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v%v,ja%v%v,val%v%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif @@ -784,14 +826,12 @@ subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_z_csput_v - subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format @@ -811,7 +851,7 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -822,11 +862,24 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& call psb_errpush(info,name) goto 9999 endif + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,nz,ia,ja,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -860,7 +913,7 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act, nz1 character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -872,9 +925,23 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& goto 9999 endif - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& - & rscale=rscale,cscale=cscale,chksz=chksz) + if (allocated(a%a)) then + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,nz1,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,nzin=nzin,& + & rscale=rscale,cscale=cscale,chksz=chksz) + call a%and%csget(imin,imax,nz,ia,ja,val,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,nzin=nz1,& + & rscale=rscale,cscale=cscale,chksz=chksz) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (info /= psb_success_) goto 9999 @@ -889,8 +956,6 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_z_csgetrow - - subroutine psb_z_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) ! Output is always in COO format @@ -936,9 +1001,22 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& end if if (info == psb_success_) then - call a%a%csget(imin,imax,acoo,info,& - & jmin=jmin,jmax=jmax,iren=iren,append=append,& - & rscale=rscale,cscale=cscale) + if (allocated(a%a)) then + call a%a%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + else if (allocated(a%ad)) then + call a%ad%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=append,& + & rscale=rscale,cscale=cscale) + call a%and%csget(imin,imax,acoo,info,& + & jmin=jmin,jmax=jmax,iren=iren,append=.true.,& + & rscale=rscale,cscale=cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif else info = psb_err_alloc_dealloc_ end if @@ -974,6 +1052,7 @@ subroutine psb_z_tril(a,l,info,diag,imin,imax,& character(len=20) :: name='tril' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_z_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -984,25 +1063,56 @@ subroutine psb_z_tril(a,l,info,diag,imin,imax,& endif allocate(lcoo,stat=info) call l%free() - if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) - call u%free() - if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,ucoo) - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%tril(lcoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1031,6 +1141,7 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& character(len=20) :: name='triu' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat), allocatable :: lcoo, ucoo + type(psb_z_coo_sparse_mat) :: acoo, ac1,ac2 info = psb_success_ @@ -1044,24 +1155,55 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& allocate(ucoo,stat=info) call u%free() - if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) - call l%free() - if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,lcoo) - if (info == psb_success_) call move_alloc(lcoo,l%a) - if (info == psb_success_) call l%cscnv(info,mold=a%a) - else - if (info == psb_success_) then - call a%a%triu(ucoo,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) else - info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if end if - end if - if (info == psb_success_) call move_alloc(ucoo,u%a) - if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,acoo,a%get_nrows(),a%get_ncols(),info) + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call acoo%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -1070,7 +1212,6 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& return - end subroutine psb_z_triu @@ -1093,6 +1234,7 @@ subroutine psb_z_csclip(a,b,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat), allocatable :: acoo + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1103,13 +1245,25 @@ subroutine psb_z_csclip(a,b,info,& endif allocate(acoo,stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if call b%free() - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 @@ -1142,6 +1296,7 @@ subroutine psb_z_csclip_ip(a,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat), allocatable :: acoo + type(psb_z_coo_sparse_mat) :: ac1,ac2,aa info = psb_success_ call psb_erractionsave(err_act) @@ -1151,13 +1306,20 @@ subroutine psb_z_csclip_ip(a,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + if (allocated(a%a)) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - else - info = psb_err_alloc_dealloc_ - end if + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) if (info /= psb_success_) goto 9999 @@ -1190,6 +1352,7 @@ subroutine psb_z_b_csclip(a,b,info,& integer(psb_ipk_) :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1199,8 +1362,19 @@ subroutine psb_z_b_csclip(a,b,info,& goto 9999 endif - call a%a%csclip(b,info,& - & imin,imax,jmin,jmax,rscale,cscale) + if (allocated(a%a)) then + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1234,36 +1408,39 @@ subroutine psb_z_split_nd(a,n_rows,n_cols,info) info = psb_success_ name = 'psb_split' call psb_erractionsave(err_act) - allocate(aclip) - call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) - allocate(a%ad,mold=a%a) - call a%ad%mv_from_coo(acoo,info) - call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) - if (use_ecsr) then - allocate(andclip) - call andclip%mv_from_coo(acoo,info) - call move_alloc(andclip,a%and) - else - allocate(a%and,mold=a%a) - call a%and%mv_from_coo(acoo,info) + if (allocated(a%a)) then + allocate(aclip) + call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.) + allocate(a%ad,mold=a%a) + call a%ad%mv_from_coo(acoo,info) + call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.) + if (use_ecsr) then + allocate(andclip) + call andclip%mv_from_coo(acoo,info) + call move_alloc(andclip,a%and) + else + allocate(a%and,mold=a%a) + call a%and%mv_from_coo(acoo,info) + end if + call a%a%free() + deallocate(a%a) end if - if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='cscnv') goto 9999 endif - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) - + return - + end subroutine psb_z_split_nd -subroutine psb_z_merge_nd(a,n_rows,n_cols,info) +subroutine psb_z_merge_nd(a,n_rows,n_cols,info,acoo) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_merge_nd @@ -1271,10 +1448,11 @@ subroutine psb_z_merge_nd(a,n_rows,n_cols,info) class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n_rows, n_cols integer(psb_ipk_), intent(out) :: info + class(psb_z_coo_sparse_mat), intent(out), optional :: acoo !!$ integer(psb_ipk_),optional, intent(in) :: dupl !!$ character(len=*), optional, intent(in) :: type !!$ class(psb_z_base_sparse_mat), intent(in), optional :: mold - type(psb_z_coo_sparse_mat) :: acoo1,acoo2 + type(psb_z_coo_sparse_mat) :: acoo1 integer(psb_ipk_) :: nz logical, parameter :: use_ecsr=.true. character(len=20) :: name, ch_err @@ -1284,19 +1462,21 @@ subroutine psb_z_merge_nd(a,n_rows,n_cols,info) name = 'psb_split' call psb_erractionsave(err_act) - call a%ad%mv_to_coo(acoo1,info) - call acoo1%set_bld() - call acoo1%set_nrows(n_rows) - call acoo1%set_ncols(n_cols) - call a%and%mv_to_coo(acoo2,info) - nz=acoo2%get_nzeros() - call acoo1%csput(nz,acoo2%ia,acoo2%ja,acoo2%val,ione,n_rows,ione,n_cols,info) - if (allocated(a%a)) then - call a%a%free() - deallocate(a%a) + call a%ad%csmerge(a%and,acoo1,n_rows,n_cols,info) + + if (present(acoo)) then + call acoo%mv_from_coo(acoo1,info) + else + call a%ad%free() + call a%and%free() + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + end if + allocate(a%a,mold=a%ad) + call a%a%mv_from_coo(acoo1,info) + deallocate(a%ad,a%and) end if - allocate(a%a,mold=a%ad) - call a%a%mv_from_coo(acoo1,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ @@ -1346,64 +1526,9 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_z_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_z_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_z_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(dupl)) then - call altmp%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call altmp%set_dupl(psb_dupl_def_) - end if - - if (debug) write(psb_err_unit,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - else - call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) - end if - end if + if (allocated(a%a)) call inner_cp_fmt(a%a,b%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_cp_fmt(a%and,b%and,info,type,mold,dupl) call b%trim() call b%set_asb() @@ -1511,65 +1636,25 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) if (a%is_null()) then info = psb_err_invalid_mat_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call a%set_dupl(dupl) - else if (a%is_bld()) then - call a%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = psb_err_many_optional_arg_ - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (.false.) then - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_z_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_z_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_z_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) - end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_errpush(info,name) + goto 9999 + endif - if (debug) write(psb_err_unit,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if - call altmp%mv_from_fmt(a%a, info) - call move_alloc(altmp,a%a) - else - call inner_mv_fmt(a%a,info,type,mold,dupl) - if (allocated(a%ad)) then - call inner_mv_fmt(a%ad,info,type,mold,dupl) - end if - if (allocated(a%and)) then - call inner_mv_fmt(a%and,info,type,mold,dupl) - end if + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 end if + + if (allocated(a%a)) call inner_mv_fmt(a%a,info,type,mold,dupl) + if (allocated(a%ad)) call inner_mv_fmt(a%ad,info,type,mold,dupl) + if (allocated(a%and)) call inner_mv_fmt(a%and,info,type,mold,dupl) if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") @@ -1660,7 +1745,6 @@ contains end subroutine psb_z_cscnv_ip - subroutine psb_z_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod @@ -1676,6 +1760,7 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) integer(psb_ipk_) :: err_act character(len=20) :: name='cscnv' logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 info = psb_success_ call psb_erractionsave(err_act) @@ -1686,7 +1771,18 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) goto 9999 endif - call a%a%cp_to_coo(altmp,info ) + if (allocated(a%a)) then + call a%a%cp_to_coo(altmp,info ) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%cp_to_coo(altmp,info ) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if @@ -1704,7 +1800,6 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1712,7 +1807,6 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) end subroutine psb_z_cscnv_base - subroutine psb_z_clip_d(a,b,info) ! Output is always in COO format use psb_error_mod @@ -1740,7 +1834,7 @@ subroutine psb_z_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info == psb_success_) call a%cp_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1799,7 +1893,7 @@ subroutine psb_z_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info == psb_success_) call a%mv_to(acoo) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) @@ -1823,7 +1917,6 @@ subroutine psb_z_clip_d_ip(a,info) call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1839,10 +1932,14 @@ subroutine psb_z_mv_from(a,b) class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + logical :: do_split + do_split = allocated(a%ad) + call a%free() allocate(a%a,mold=b, stat=info) call a%a%mv_from_fmt(b,info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) call b%free() return @@ -1859,6 +1956,10 @@ subroutine psb_z_cp_from(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. + logical :: do_split + + do_split = allocated(a%ad) + call psb_erractionsave(err_act) info = psb_success_ @@ -1872,6 +1973,7 @@ subroutine psb_z_cp_from(a,b) allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (do_split) call a%split_nd(a%get_nrows(),a%get_ncols(),info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -1892,8 +1994,16 @@ subroutine psb_z_mv_to(a,b) class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 - call b%mv_from_fmt(a%a,info) + if (allocated(a%a)) then + call b%mv_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%mv_from_coo(aa,info) + end if return end subroutine psb_z_mv_to @@ -1907,9 +2017,16 @@ subroutine psb_z_cp_to(a,b) class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 - call b%cp_from_fmt(a%a,info) - + if (allocated(a%a)) then + call b%cp_from_fmt(a%a,info) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call b%cp_from_coo(aa,info) + end if return end subroutine psb_z_cp_to @@ -1919,7 +2036,11 @@ subroutine psb_z_mold(a,b) class(psb_z_base_sparse_mat), allocatable, intent(out) :: b integer(psb_ipk_) :: info - allocate(b,mold=a%a, stat=info) + if (allocated(a%a)) then + allocate(b,mold=a%a, stat=info) + else if (allocated(a%ad)) then + allocate(b,mold=a%ad, stat=info) + end if end subroutine psb_z_mold @@ -1939,11 +2060,12 @@ subroutine psb_zspmat_type_move(a,b,info) info = psb_success_ call b%free() call move_alloc(a%a,b%a) + call move_alloc(a%ad,b%ad) + call move_alloc(a%and,b%and) return end subroutine psb_zspmat_type_move - subroutine psb_zspmat_clone(a,b,info) use psb_error_mod use psb_string_mod @@ -1963,12 +2085,17 @@ subroutine psb_zspmat_clone(a,b,info) if (allocated(a%a)) then call a%a%clone(b%a,info) end if + if (allocated(a%ad)) then + call a%ad%clone(b%ad,info) + end if + if (allocated(a%and)) then + call a%and%clone(b%and,info) + end if if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return @@ -1986,6 +2113,7 @@ subroutine psb_z_transp_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -1995,20 +2123,24 @@ subroutine psb_z_transp_1mat(a) goto 9999 endif - call a%a%transp() - + if (allocated(a%a)) then + call a%a%transp() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_z_transp_1mat - - subroutine psb_z_transp_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2020,6 +2152,7 @@ subroutine psb_z_transp_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transp' logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2029,24 +2162,29 @@ subroutine psb_z_transp_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transp() + call b%mv_from(aa) end if - call a%a%transp(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_z_transp_2mat - subroutine psb_z_transc_1mat(a) use psb_error_mod use psb_string_mod @@ -2057,6 +2195,7 @@ subroutine psb_z_transc_1mat(a) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) @@ -2066,20 +2205,25 @@ subroutine psb_z_transc_1mat(a) goto 9999 endif - call a%a%transc() + if (allocated(a%a)) then + call a%a%transc() + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call a%mv_from(aa) + end if call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_z_transc_1mat - - subroutine psb_z_transc_2mat(a,b) use psb_error_mod use psb_string_mod @@ -2091,7 +2235,7 @@ subroutine psb_z_transc_2mat(a,b) integer(psb_ipk_) :: err_act, info character(len=20) :: name='transc' logical, parameter :: debug=.false. - + type(psb_z_coo_sparse_mat) :: aa, ac1,ac2 call psb_erractionsave(err_act) if (a%is_null()) then @@ -2100,24 +2244,29 @@ subroutine psb_z_transc_2mat(a,b) goto 9999 endif call b%free() - allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - goto 9999 + if (allocated(a%a)) then + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + else if (allocated(a%ad)) then + call a%ad%cp_to_coo(ac1,info) + call a%and%cp_to_coo(ac2,info) + call ac1%csmerge(ac2,aa,a%get_nrows(),a%get_ncols(),info) + call aa%transc() + call b%mv_from(aa) end if - call a%a%transc(b%a) - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return end subroutine psb_z_transc_2mat - subroutine psb_z_asb(a,mold) use psb_z_mat_mod, psb_protect_name => psb_z_asb use psb_error_mod @@ -2137,20 +2286,46 @@ subroutine psb_z_asb(a,mold) goto 9999 endif - call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then - allocate(tmp,mold=mold) - call tmp%mv_from_fmt(a%a,info) - call a%a%free() - call move_alloc(tmp,a%a) + if (allocated(a%a)) then + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_z_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + call a%split_nd(a%get_nrows(),a%get_ncols(),info) + + else if (allocated(a%ad)) then + call a%ad%asb() + call a%and%asb() + if (present(mold)) then + if (.not.same_type_as(a%ad,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%ad,info) + call a%ad%free() + call move_alloc(tmp,a%ad) + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%and,info) + call a%and%free() + call move_alloc(tmp,a%and) + end if + else + mld => psb_z_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) end if else - mld => psb_z_get_base_mat_default() - if (.not.same_type_as(a%a,mld)) & - & call a%cscnv(info) - end if - + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2178,14 +2353,16 @@ subroutine psb_z_reinit(a,clear) call psb_errpush(info,name) goto 9999 endif - - if (a%a%has_update()) then - call a%a%reinit(clear) + if (allocated(a%a)) then + call inner_reinit(a%a,name,info) + else if (allocated(a%ad)) then + call inner_reinit(a%ad,name,info) + call inner_reinit(a%and,name,info) else - info = psb_err_missing_override_method_ + info = psb_err_invalid_mat_state_ call psb_errpush(info,name) - goto 9999 endif + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return @@ -2194,7 +2371,19 @@ subroutine psb_z_reinit(a,clear) 9999 call psb_error_handler(err_act) return - +contains + subroutine inner_reinit(aa,name,info) + class(psb_z_base_sparse_mat) :: aa + character(len=*) :: name + integer(psb_ipk_) :: info + info = 0 + if (aa%has_update()) then + call aa%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + endif + end subroutine inner_reinit end subroutine psb_z_reinit @@ -2212,7 +2401,10 @@ end subroutine psb_z_reinit ! ! ! == =================================== - +! +! +! What do we do here?????? +! subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -2348,7 +2540,15 @@ subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2383,8 +2583,15 @@ subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - + if (allocated(a%a)) then + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + else if (allocated(a%ad)) then + call a%ad%spsm(alpha,x,beta,y,info,trans,scale,d) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2430,16 +2637,32 @@ subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then - info = psb_err_invalid_vect_state_ - call psb_errpush(info,name) - goto 9999 - endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + if (allocated(a%a)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if + else if (allocated(a%ad)) then + if (present(d)) then + if (.not.allocated(d%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + else + call a%ad%spsm(alpha,x%v,beta,y%v,info,trans,scale) + end if else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) - end if + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif if (info /= psb_success_) goto 9999 @@ -2473,7 +2696,15 @@ function psb_z_maxval(a) result(res) goto 9999 endif - res = a%a%maxval() + if (allocated(a%a)) then + res = a%a%maxval() + else if (allocated(a%ad)) then + res = max(a%ad%maxval(),a%and%maxval()) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif return @@ -2503,7 +2734,8 @@ function psb_z_csnmi(a) result(res) goto 9999 endif - res = a%a%spnmi() + res = maxval(a%arwsum(info)) + return @@ -2534,9 +2766,9 @@ function psb_z_csnm1(a) result(res) goto 9999 endif - res = a%a%spnm1() - return + res = maxval(a%aclsum(info)) + return 9999 call psb_error_handler(err_act) @@ -2551,7 +2783,7 @@ function psb_z_rowsum(a,info) result(d) use psb_const_mod implicit none class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), allocatable :: d(:) + complex(psb_dpk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2567,7 +2799,17 @@ function psb_z_rowsum(a,info) result(d) endif allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%rowsum(d) + if (allocated(a%a)) then + call a%a%rowsum(d) + else if (allocated(a%ad)) then + call a%ad%rowsum(d) + call a%and%rowsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2584,7 +2826,7 @@ function psb_z_arwsum(a,info) result(d) use psb_const_mod implicit none class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2601,7 +2843,17 @@ function psb_z_arwsum(a,info) result(d) allocate(d(max(1,a%a%get_nrows())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%arwsum(d) + if (allocated(a%a)) then + call a%a%arwsum(d) + else if (allocated(a%ad)) then + call a%ad%arwsum(d) + call a%and%arwsum(d1) + d=d+d1 + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2618,7 +2870,7 @@ function psb_z_colsum(a,info) result(d) use psb_const_mod implicit none class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), allocatable :: d(:) + complex(psb_dpk_), allocatable :: d(:), d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2635,8 +2887,18 @@ function psb_z_colsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%colsum(d) - + if (allocated(a%a)) then + call a%a%colsum(d) + else if (allocated(a%ad)) then + call a%ad%colsum(d) + call a%and%colsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call psb_erractionrestore(err_act) return @@ -2652,7 +2914,7 @@ function psb_z_aclsum(a,info) result(d) use psb_const_mod implicit none class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) + real(psb_dpk_), allocatable :: d(:),d1(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2669,7 +2931,17 @@ function psb_z_aclsum(a,info) result(d) allocate(d(max(1,a%a%get_ncols())), stat=info) if (info /= psb_success_) goto 9999 - call a%a%aclsum(d) + if (allocated(a%a)) then + call a%a%aclsum(d) + else if (allocated(a%ad)) then + call a%ad%aclsum(d) + call a%and%aclsum(d1) + d = [d,d1] + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif call psb_erractionrestore(err_act) return @@ -2707,7 +2979,15 @@ function psb_z_get_diag(a,info) result(d) call psb_errpush(info,name) goto 9999 end if - call a%a%get_diag(d,info) + if (allocated(a%a)) then + call a%a%get_diag(d,info) + else if (allocated(a%ad)) then + call a%ad%get_diag(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2742,7 +3022,18 @@ subroutine psb_z_scal(d,a,info,side) goto 9999 endif - call a%a%scal(d,info,side=side) + if (allocated(a%a)) then + call a%a%scal(d,info,side=side) + else if (allocated(a%ad)) then + call a%ad%scal(d,info,side=side) + ! + ! FIXME + ! + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2776,7 +3067,16 @@ subroutine psb_z_scals(d,a,info) goto 9999 endif - call a%a%scal(d,info) + if (allocated(a%a)) then + call a%a%scal(d,info) + else if (allocated(a%ad)) then + call a%ad%scal(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2809,7 +3109,16 @@ subroutine psb_z_scalplusidentity(d,a,info) goto 9999 endif - call a%a%scalpid(d,info) + if (allocated(a%a)) then + call a%a%scalpid(d,info) + else if (allocated(a%ad)) then + call a%ad%scalpid(d,info) + call a%and%scal(d,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2844,7 +3153,16 @@ subroutine psb_z_spaxpby(alpha,a,beta,b,info) goto 9999 endif - call a%a%spaxpby(alpha,beta,b%a,info) + if (allocated(a%a)) then + call a%a%spaxpby(alpha,beta,b%a,info) + else if (allocated(a%ad)) then + call a%ad%spaxpby(alpha,beta,b%a,info) + call a%and%spaxpby(alpha,zone,b%a,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2856,6 +3174,7 @@ subroutine psb_z_spaxpby(alpha,a,beta,b,info) end subroutine psb_z_spaxpby + function psb_z_cmpval(a,val,tol,info) result(res) use psb_error_mod use psb_const_mod @@ -2880,7 +3199,15 @@ function psb_z_cmpval(a,val,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(val,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(val,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(val,tol,info) .and. a%and%spcmp(val,tol,info) +1 else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2916,7 +3243,15 @@ function psb_z_cmpmat(a,b,tol,info) result(res) goto 9999 endif - res = a%a%spcmp(b%a,tol,info) + if (allocated(a%a)) then + res = a%a%spcmp(b%a,tol,info) + else if (allocated(a%ad)) then + res = a%ad%spcmp(b%ad,tol,info) .and. a%and%spcmp(b%and,tol,info) + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + endif + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -2939,6 +3274,7 @@ subroutine psb_z_mv_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) @@ -2956,6 +3292,7 @@ subroutine psb_z_cp_from_lb(a,b) integer(psb_ipk_) :: info info = psb_success_ + call a%free() if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%cp_from_lfmt(b,info) @@ -2970,13 +3307,19 @@ subroutine psb_z_mv_to_lb(a,b) class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info + type(psb_z_coo_sparse_mat) :: acoo if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%mv_to_lfmt(b,info) - call a%free() end if + call a%free() end subroutine psb_z_mv_to_lb @@ -2985,12 +3328,18 @@ subroutine psb_z_cp_to_lb(a,b) use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_to_lb implicit none - class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + type(psb_z_coo_sparse_mat) :: acoo + if (.not.allocated(a%a)) then - call b%free() + if (allocated(a%ad)) then + call a%merge_nd(a%get_nrows(),a%get_ncols(),info,acoo=acoo) + call acoo%mv_to_lfmt(b,info) + else + call b%free() + end if else call a%a%cp_to_lfmt(b,info) end if