From 56fd1cfbea41ba63402f620089c75c94cef685c2 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 23 Mar 2010 13:17:25 +0000 Subject: [PATCH] psblas3: base/modules/Makefile base/modules/psb_base_mat_mod.f03 base/modules/psb_c_base_mat_mod.f03 base/modules/psb_c_csc_mat_mod.f03 base/modules/psb_c_csr_mat_mod.f03 base/modules/psb_c_mat_mod.f03 base/modules/psb_d_base_mat_mod.f03 base/modules/psb_d_csc_mat_mod.f03 base/modules/psb_d_csr_mat_mod.f03 base/modules/psb_d_mat_mod.f03 base/modules/psb_s_base_mat_mod.f03 base/modules/psb_s_csc_mat_mod.f03 base/modules/psb_s_csr_mat_mod.f03 base/modules/psb_s_mat_mod.f03 base/modules/psb_sort_mod.f90 base/modules/psb_z_base_mat_mod.f03 base/modules/psb_z_csc_mat_mod.f03 base/modules/psb_z_csr_mat_mod.f03 base/modules/psb_z_mat_mod.f03 base/modules/psi_mod.f90 base/modules/psi_serial_mod.f90 base/psblas/psb_cnrmi.f90 base/psblas/psb_dnrmi.f90 base/psblas/psb_snrmi.f90 base/psblas/psb_znrmi.f90 base/serial/Makefile base/serial/f03/Makefile base/serial/f03/psb_base_mat_impl.f03 base/serial/f03/psb_c_base_mat_impl.f03 base/serial/f03/psb_c_coo_impl.f03 base/serial/f03/psb_c_csc_impl.f03 base/serial/f03/psb_c_csr_impl.f03 base/serial/f03/psb_c_mat_impl.f03 base/serial/f03/psb_d_base_mat_impl.f03 base/serial/f03/psb_d_coo_impl.f03 base/serial/f03/psb_d_csc_impl.f03 base/serial/f03/psb_d_csr_impl.f03 base/serial/f03/psb_d_mat_impl.f03 base/serial/f03/psb_s_base_mat_impl.f03 base/serial/f03/psb_s_coo_impl.f03 base/serial/f03/psb_s_csc_impl.f03 base/serial/f03/psb_s_csr_impl.f03 base/serial/f03/psb_s_mat_impl.f03 base/serial/f03/psb_z_base_mat_impl.f03 base/serial/f03/psb_z_coo_impl.f03 base/serial/f03/psb_z_csc_impl.f03 base/serial/f03/psb_z_csr_impl.f03 base/serial/f03/psb_z_mat_impl.f03 base/serial/psb_sort_impl.f90 base/serial/psi_impl.f90 base/serial/psi_serial_impl.f90 test/pargen/runs/ppde.inp test/torture test/torture/Makefile test/torture/psb_mvsv_tester.f90 test/torture/psbtf.f90 test/torture/runs util/Makefile util/psb_hbio_impl.f90 util/psb_hbio_mod.f90 util/psb_mat_dist_impl.f90 util/psb_mat_dist_mod.f90 util/psb_mmio_impl.f90 util/psb_mmio_mod.f90 Merged (at r 4082) the XLF-TEST branch, where we have decoupled interface and implementation for serial stuff. --- base/modules/Makefile | 2 +- base/modules/psb_base_mat_mod.f03 | 713 +- base/modules/psb_c_base_mat_mod.f03 | 3133 ++---- base/modules/psb_c_csc_mat_mod.f03 | 1587 +--- base/modules/psb_c_csr_mat_mod.f03 | 1611 +--- base/modules/psb_c_mat_mod.f03 | 2159 ++--- base/modules/psb_d_base_mat_mod.f03 | 3100 ++---- base/modules/psb_d_csc_mat_mod.f03 | 1598 +--- base/modules/psb_d_csr_mat_mod.f03 | 1603 +--- base/modules/psb_d_mat_mod.f03 | 2555 ++--- base/modules/psb_s_base_mat_mod.f03 | 3069 ++---- base/modules/psb_s_csc_mat_mod.f03 | 1598 +--- base/modules/psb_s_csr_mat_mod.f03 | 1605 +--- base/modules/psb_s_mat_mod.f03 | 2456 ++--- base/modules/psb_sort_mod.f90 | 5020 +--------- base/modules/psb_z_base_mat_mod.f03 | 3132 ++---- base/modules/psb_z_csc_mat_mod.f03 | 1583 +-- base/modules/psb_z_csr_mat_mod.f03 | 1607 +--- base/modules/psb_z_mat_mod.f03 | 2159 ++--- base/modules/psi_mod.f90 | 2544 +---- base/modules/psi_serial_mod.f90 | 1428 +-- base/psblas/psb_cnrmi.f90 | 2 +- base/psblas/psb_dnrmi.f90 | 2 +- base/psblas/psb_snrmi.f90 | 2 +- base/psblas/psb_znrmi.f90 | 2 +- base/serial/Makefile | 2 +- base/serial/f03/Makefile | 13 +- base/serial/f03/psb_base_mat_impl.f03 | 337 + base/serial/f03/psb_c_base_mat_impl.f03 | 1078 +++ base/serial/f03/psb_c_coo_impl.f03 | 1023 +- base/serial/f03/psb_c_csc_impl.f03 | 787 +- base/serial/f03/psb_c_csr_impl.f03 | 739 +- base/serial/f03/psb_c_mat_impl.f03 | 1990 ++++ base/serial/f03/psb_d_base_mat_impl.f03 | 1078 +++ base/serial/f03/psb_d_coo_impl.f03 | 1028 +- base/serial/f03/psb_d_csc_impl.f03 | 810 +- base/serial/f03/psb_d_csr_impl.f03 | 1080 ++- base/serial/f03/psb_d_mat_impl.f03 | 1990 ++++ base/serial/f03/psb_s_base_mat_impl.f03 | 1078 +++ base/serial/f03/psb_s_coo_impl.f03 | 1047 +- base/serial/f03/psb_s_csc_impl.f03 | 982 +- base/serial/f03/psb_s_csr_impl.f03 | 1178 ++- base/serial/f03/psb_s_mat_impl.f03 | 1990 ++++ base/serial/f03/psb_z_base_mat_impl.f03 | 1078 +++ base/serial/f03/psb_z_coo_impl.f03 | 1023 +- base/serial/f03/psb_z_csc_impl.f03 | 787 +- base/serial/f03/psb_z_csr_impl.f03 | 737 +- base/serial/f03/psb_z_mat_impl.f03 | 1990 ++++ base/serial/psb_sort_impl.f90 | 4586 +++++++++ base/serial/psi_impl.f90 | 2303 +++++ base/serial/psi_serial_impl.f90 | 1242 +++ test/pargen/runs/ppde.inp | 2 +- test/torture/Makefile | 37 + test/torture/psb_mvsv_tester.f90 | 11089 ++++++++++++++++++++++ test/torture/psbtf.f90 | 754 ++ util/Makefile | 10 +- util/psb_hbio_impl.f90 | 1320 +++ util/psb_hbio_mod.f90 | 1378 +-- util/psb_mat_dist_impl.f90 | 1810 ++++ util/psb_mat_dist_mod.f90 | 2122 +---- util/psb_mmio_impl.f90 | 1423 +++ util/psb_mmio_mod.f90 | 1581 +-- 62 files changed, 54423 insertions(+), 43349 deletions(-) create mode 100644 base/serial/f03/psb_base_mat_impl.f03 create mode 100644 base/serial/f03/psb_c_base_mat_impl.f03 create mode 100644 base/serial/f03/psb_c_mat_impl.f03 create mode 100644 base/serial/f03/psb_d_base_mat_impl.f03 create mode 100644 base/serial/f03/psb_d_mat_impl.f03 create mode 100644 base/serial/f03/psb_s_base_mat_impl.f03 create mode 100644 base/serial/f03/psb_s_mat_impl.f03 create mode 100644 base/serial/f03/psb_z_base_mat_impl.f03 create mode 100644 base/serial/f03/psb_z_mat_impl.f03 create mode 100644 base/serial/psb_sort_impl.f90 create mode 100644 base/serial/psi_impl.f90 create mode 100644 base/serial/psi_serial_impl.f90 create mode 100644 test/torture/Makefile create mode 100644 test/torture/psb_mvsv_tester.f90 create mode 100644 test/torture/psbtf.f90 create mode 100644 util/psb_hbio_impl.f90 create mode 100644 util/psb_mat_dist_impl.f90 create mode 100644 util/psb_mmio_impl.f90 diff --git a/base/modules/Makefile b/base/modules/Makefile index 8b5df86f..d6aaea52 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -44,7 +44,7 @@ psb_c_mat_mod.o: psb_c_base_mat_mod.o psb_c_csr_mat_mod.o psb_c_csc_mat_mod.o psb_z_mat_mod.o: psb_z_base_mat_mod.o psb_z_csr_mat_mod.o psb_z_csc_mat_mod.o psb_s_csc_mat_mod.o psb_s_csr_mat_mod.o: psb_s_base_mat_mod.o psb_d_csc_mat_mod.o psb_d_csr_mat_mod.o: psb_d_base_mat_mod.o -psb_dccsc_mat_mod.o psb_c_csr_mat_mod.o: psb_c_base_mat_mod.o +psb_c_csc_mat_mod.o psb_c_csr_mat_mod.o: psb_c_base_mat_mod.o psb_z_csc_mat_mod.o psb_z_csr_mat_mod.o: psb_z_base_mat_mod.o psb_mat_mod.o: psb_s_mat_mod.o psb_d_mat_mod.o psb_c_mat_mod.o psb_z_mat_mod.o psb_realloc_mod.o : psb_error_mod.o diff --git a/base/modules/psb_base_mat_mod.f03 b/base/modules/psb_base_mat_mod.f03 index 3b0da852..315233d5 100644 --- a/base/modules/psb_base_mat_mod.f03 +++ b/base/modules/psb_base_mat_mod.f03 @@ -20,44 +20,44 @@ module psb_base_mat_mod ! ! ! ==================================== - procedure, pass(a) :: get_nrows - procedure, pass(a) :: get_ncols - procedure, pass(a) :: get_nzeros - procedure, pass(a) :: get_nz_row - procedure, pass(a) :: get_size - procedure, pass(a) :: get_state - procedure, pass(a) :: get_dupl - procedure, pass(a) :: get_fmt - procedure, pass(a) :: get_aux - procedure, pass(a) :: is_null - procedure, pass(a) :: is_bld - procedure, pass(a) :: is_upd - procedure, pass(a) :: is_asb - procedure, pass(a) :: is_sorted - procedure, pass(a) :: is_upper - procedure, pass(a) :: is_lower - procedure, pass(a) :: is_triangle - procedure, pass(a) :: is_unit + procedure, pass(a) :: get_nrows => psb_base_get_nrows + procedure, pass(a) :: get_ncols => psb_base_get_ncols + procedure, pass(a) :: get_nzeros => psb_base_get_nzeros + procedure, pass(a) :: get_nz_row => psb_base_get_nz_row + procedure, pass(a) :: get_size => psb_base_get_size + procedure, pass(a) :: get_state => psb_base_get_state + procedure, pass(a) :: get_dupl => psb_base_get_dupl + procedure, pass(a) :: get_fmt => psb_base_get_fmt + procedure, pass(a) :: get_aux => psb_base_get_aux + procedure, pass(a) :: is_null => psb_base_is_null + procedure, pass(a) :: is_bld => psb_base_is_bld + procedure, pass(a) :: is_upd => psb_base_is_upd + procedure, pass(a) :: is_asb => psb_base_is_asb + procedure, pass(a) :: is_sorted => psb_base_is_sorted + procedure, pass(a) :: is_upper => psb_base_is_upper + procedure, pass(a) :: is_lower => psb_base_is_lower + procedure, pass(a) :: is_triangle => psb_base_is_triangle + procedure, pass(a) :: is_unit => psb_base_is_unit ! ==================================== ! ! Setters ! ! ==================================== - procedure, pass(a) :: set_nrows - procedure, pass(a) :: set_ncols - procedure, pass(a) :: set_dupl - procedure, pass(a) :: set_state - procedure, pass(a) :: set_null - procedure, pass(a) :: set_bld - procedure, pass(a) :: set_upd - procedure, pass(a) :: set_asb - procedure, pass(a) :: set_sorted - procedure, pass(a) :: set_upper - procedure, pass(a) :: set_lower - procedure, pass(a) :: set_triangle - procedure, pass(a) :: set_unit - procedure, pass(a) :: set_aux + procedure, pass(a) :: set_nrows => psb_base_set_nrows + procedure, pass(a) :: set_ncols => psb_base_set_ncols + procedure, pass(a) :: set_dupl => psb_base_set_dupl + procedure, pass(a) :: set_state => psb_base_set_state + procedure, pass(a) :: set_null => psb_base_set_null + procedure, pass(a) :: set_bld => psb_base_set_bld + procedure, pass(a) :: set_upd => psb_base_set_upd + procedure, pass(a) :: set_asb => psb_base_set_asb + procedure, pass(a) :: set_sorted => psb_base_set_sorted + procedure, pass(a) :: set_upper => psb_base_set_upper + procedure, pass(a) :: set_lower => psb_base_set_lower + procedure, pass(a) :: set_triangle => psb_base_set_triangle + procedure, pass(a) :: set_unit => psb_base_set_unit + procedure, pass(a) :: set_aux => psb_base_set_aux ! ==================================== @@ -65,164 +65,258 @@ module psb_base_mat_mod ! Data management ! ! ==================================== - procedure, pass(a) :: get_neigh - procedure, pass(a) :: allocate_mnnz - procedure, pass(a) :: reallocate_nz - procedure, pass(a) :: free - procedure, pass(a) :: trim - procedure, pass(a) :: reinit + procedure, pass(a) :: get_neigh => psb_base_get_neigh + procedure, pass(a) :: free => psb_base_free + procedure, pass(a) :: trim => psb_base_trim + procedure, pass(a) :: reinit => psb_base_reinit + procedure, pass(a) :: allocate_mnnz => psb_base_allocate_mnnz + procedure, pass(a) :: reallocate_nz => psb_base_reallocate_nz generic, public :: allocate => allocate_mnnz generic, public :: reallocate => reallocate_nz - procedure, pass(a) :: csgetptn + procedure, pass(a) :: csgetptn => psb_base_csgetptn generic, public :: csget => csgetptn - procedure, pass(a) :: print => sparse_print - procedure, pass(a) :: sizeof - procedure, pass(a) :: base_cp_from - generic, public :: cp_from => base_cp_from - procedure, pass(a) :: base_mv_from - generic, public :: mv_from => base_mv_from - procedure, pass(a) :: base_transp_1mat - procedure, pass(a) :: base_transp_2mat - generic, public :: transp => base_transp_1mat, base_transp_2mat - procedure, pass(a) :: base_transc_1mat - procedure, pass(a) :: base_transc_2mat - generic, public :: transc => base_transc_1mat, base_transc_2mat + procedure, pass(a) :: print => psb_base_sparse_print + procedure, pass(a) :: sizeof => psb_base_sizeof + procedure, pass(a) :: psb_base_cp_from + generic, public :: cp_from => psb_base_cp_from + procedure, pass(a) :: psb_base_mv_from + generic, public :: mv_from => psb_base_mv_from + procedure, pass(a) :: transp_1mat => psb_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_base_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_base_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat end type psb_base_sparse_mat - private :: set_nrows, set_ncols, set_dupl, set_state, & - & set_null, set_bld, set_upd, set_asb, set_sorted, set_upper, & - & set_lower, set_triangle, set_unit, get_nrows, get_ncols, & - & get_nzeros, get_size, get_state, get_dupl, is_null, is_bld, & - & is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, & - & is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, & - & free, sparse_print, get_fmt, trim, sizeof, reinit, csgetptn, & - & get_nz_row, get_aux, set_aux, base_cp_from, base_mv_from, & - & base_transp_1mat, base_transp_2mat, base_transc_1mat, base_transc_2mat + + interface + function psb_base_get_nz_row(idx,a) result(res) + import psb_base_sparse_mat, psb_long_int_k_ + integer, intent(in) :: idx + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + end function psb_base_get_nz_row + end interface + + interface + function psb_base_get_nzeros(a) result(res) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + end function psb_base_get_nzeros + end interface + + interface + function psb_base_get_size(a) result(res) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + end function psb_base_get_size + end interface + + interface + subroutine psb_base_reinit(a,clear) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_base_reinit + end interface + + interface + subroutine psb_base_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_base_sparse_mat, psb_long_int_k_ + integer, intent(in) :: iout + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_base_sparse_print + end interface + + interface + subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_base_csgetptn + end interface + + interface + subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_base_get_neigh + end interface + + interface + subroutine psb_base_allocate_mnnz(m,n,a,nz) + import psb_base_sparse_mat, psb_long_int_k_ + integer, intent(in) :: m,n + class(psb_base_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_base_allocate_mnnz + end interface + + interface + subroutine psb_base_reallocate_nz(nz,a) + import psb_base_sparse_mat, psb_long_int_k_ + integer, intent(in) :: nz + class(psb_base_sparse_mat), intent(inout) :: a + end subroutine psb_base_reallocate_nz + end interface + + interface + subroutine psb_base_free(a) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(inout) :: a + end subroutine psb_base_free + end interface + + interface + subroutine psb_base_trim(a) + import psb_base_sparse_mat, psb_long_int_k_ + class(psb_base_sparse_mat), intent(inout) :: a + end subroutine psb_base_trim + end interface + contains - function sizeof(a) result(res) + function psb_base_sizeof(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 - end function sizeof - + end function psb_base_sizeof - - function get_fmt(a) result(res) + function psb_base_get_fmt(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a character(len=5) :: res res = 'NULL' - end function get_fmt + end function psb_base_get_fmt - function get_dupl(a) result(res) + function psb_base_get_dupl(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a integer :: res res = a%duplicate - end function get_dupl + end function psb_base_get_dupl - function get_state(a) result(res) + function psb_base_get_state(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a integer :: res res = a%state - end function get_state + end function psb_base_get_state - function get_nrows(a) result(res) + function psb_base_get_nrows(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a integer :: res res = a%m - end function get_nrows + end function psb_base_get_nrows - function get_ncols(a) result(res) + function psb_base_get_ncols(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a integer :: res res = a%n - end function get_ncols + end function psb_base_get_ncols - subroutine set_aux(v,a) + subroutine psb_base_set_aux(v,a) implicit none class(psb_base_sparse_mat), intent(inout) :: a integer, intent(in) :: v(:) ! TBD write(0,*) 'SET_AUX is empty right now ' - end subroutine set_aux + end subroutine psb_base_set_aux - subroutine get_aux(v,a) + subroutine psb_base_get_aux(v,a) implicit none class(psb_base_sparse_mat), intent(in) :: a integer, intent(out), allocatable :: v(:) ! TBD write(0,*) 'GET_AUX is empty right now ' - end subroutine get_aux + end subroutine psb_base_get_aux - subroutine set_nrows(m,a) + subroutine psb_base_set_nrows(m,a) implicit none class(psb_base_sparse_mat), intent(inout) :: a integer, intent(in) :: m a%m = m - end subroutine set_nrows + end subroutine psb_base_set_nrows - subroutine set_ncols(n,a) + subroutine psb_base_set_ncols(n,a) implicit none class(psb_base_sparse_mat), intent(inout) :: a integer, intent(in) :: n a%n = n - end subroutine set_ncols - + end subroutine psb_base_set_ncols + - subroutine set_state(n,a) + subroutine psb_base_set_state(n,a) implicit none class(psb_base_sparse_mat), intent(inout) :: a integer, intent(in) :: n a%state = n - end subroutine set_state + end subroutine psb_base_set_state - subroutine set_dupl(n,a) + subroutine psb_base_set_dupl(n,a) implicit none class(psb_base_sparse_mat), intent(inout) :: a integer, intent(in) :: n a%duplicate = n - end subroutine set_dupl + end subroutine psb_base_set_dupl - subroutine set_null(a) + subroutine psb_base_set_null(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_null_ - end subroutine set_null + end subroutine psb_base_set_null - subroutine set_bld(a) + subroutine psb_base_set_bld(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_bld_ - end subroutine set_bld + end subroutine psb_base_set_bld - subroutine set_upd(a) + subroutine psb_base_set_upd(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_upd_ - end subroutine set_upd + end subroutine psb_base_set_upd - subroutine set_asb(a) + subroutine psb_base_set_asb(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_asb_ - end subroutine set_asb + end subroutine psb_base_set_asb - subroutine set_sorted(a,val) + subroutine psb_base_set_sorted(a,val) implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val @@ -232,9 +326,9 @@ contains else a%sorted = .true. end if - end subroutine set_sorted + end subroutine psb_base_set_sorted - subroutine set_triangle(a,val) + subroutine psb_base_set_triangle(a,val) implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val @@ -244,9 +338,9 @@ contains else a%triangle = .true. end if - end subroutine set_triangle + end subroutine psb_base_set_triangle - subroutine set_unit(a,val) + subroutine psb_base_set_unit(a,val) implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val @@ -256,9 +350,9 @@ contains else a%unitd = .true. end if - end subroutine set_unit + end subroutine psb_base_set_unit - subroutine set_lower(a,val) + subroutine psb_base_set_lower(a,val) implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val @@ -268,9 +362,9 @@ contains else a%upper = .false. end if - end subroutine set_lower + end subroutine psb_base_set_lower - subroutine set_upper(a,val) + subroutine psb_base_set_upper(a,val) implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val @@ -280,175 +374,72 @@ contains else a%upper = .true. end if - end subroutine set_upper + end subroutine psb_base_set_upper - function is_triangle(a) result(res) + function psb_base_is_triangle(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%triangle - end function is_triangle + end function psb_base_is_triangle - function is_unit(a) result(res) + function psb_base_is_unit(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%unitd - end function is_unit + end function psb_base_is_unit - function is_upper(a) result(res) + function psb_base_is_upper(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%upper - end function is_upper + end function psb_base_is_upper - function is_lower(a) result(res) + function psb_base_is_lower(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = .not.a%upper - end function is_lower + end function psb_base_is_lower - function is_null(a) result(res) + function psb_base_is_null(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_null_) - end function is_null + end function psb_base_is_null - function is_bld(a) result(res) + function psb_base_is_bld(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_bld_) - end function is_bld + end function psb_base_is_bld - function is_upd(a) result(res) + function psb_base_is_upd(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_upd_) - end function is_upd + end function psb_base_is_upd - function is_asb(a) result(res) + function psb_base_is_asb(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_asb_) - end function is_asb + end function psb_base_is_asb - function is_sorted(a) result(res) + function psb_base_is_sorted(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%sorted - end function is_sorted + end function psb_base_is_sorted - - function get_nz_row(idx,a) result(res) - use psb_error_mod - implicit none - integer, intent(in) :: idx - class(psb_base_sparse_mat), intent(in) :: a - integer :: res - - Integer :: err_act - character(len=20) :: name='base_get_nz_row' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - res = -1 - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end function get_nz_row - - function get_nzeros(a) result(res) - use psb_error_mod - implicit none - class(psb_base_sparse_mat), intent(in) :: a - integer :: res - - Integer :: err_act - character(len=20) :: name='base_get_nzeros' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - res = -1 - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end function get_nzeros - - function get_size(a) result(res) - use psb_error_mod - implicit none - class(psb_base_sparse_mat), intent(in) :: a - integer :: res - - Integer :: err_act - character(len=20) :: name='get_size' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - res = -1 - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end function get_size - - subroutine reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_base_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - info = 700 - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine reinit - - - ! - ! - subroutine base_mv_from(a,b) - use psb_error_mod + subroutine psb_base_mv_from(a,b) implicit none class(psb_base_sparse_mat), intent(out) :: a @@ -464,12 +455,9 @@ contains a%sorted = b%sorted call move_alloc(b%aux,a%aux) - return - - end subroutine base_mv_from - - subroutine base_cp_from(a,b) - use psb_error_mod + end subroutine psb_base_mv_from + + subroutine psb_base_cp_from(a,b) implicit none class(psb_base_sparse_mat), intent(out) :: a @@ -487,16 +475,10 @@ contains allocate(a%aux(size(b%aux))) a%aux(:) = b%aux(:) end if - return - - end subroutine base_cp_from + end subroutine psb_base_cp_from - ! - ! Here we go. - ! - subroutine base_transp_2mat(a,b) - use psb_error_mod + subroutine psb_base_transp_2mat(a,b) implicit none class(psb_base_sparse_mat), intent(out) :: a @@ -515,22 +497,18 @@ contains a%aux(:) = b%aux(:) end if - return - - end subroutine base_transp_2mat + end subroutine psb_base_transp_2mat - subroutine base_transc_2mat(a,b) - use psb_error_mod + subroutine psb_base_transc_2mat(a,b) implicit none class(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(in) :: b call a%transp(b) - end subroutine base_transc_2mat + end subroutine psb_base_transc_2mat - subroutine base_transp_1mat(a) - use psb_error_mod + subroutine psb_base_transp_1mat(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a @@ -546,246 +524,15 @@ contains a%upper = .not.a%upper a%sorted = .false. - return - - end subroutine base_transp_1mat + end subroutine psb_base_transp_1mat - subroutine base_transc_1mat(a) - use psb_error_mod + subroutine psb_base_transc_1mat(a) implicit none class(psb_base_sparse_mat), intent(inout) :: a call a%transp() - end subroutine base_transc_1mat - - - subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_error_mod - implicit none - - integer, intent(in) :: iout - class(psb_base_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act, info - character(len=20) :: name='sparse_print' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - info = 700 - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine sparse_print - - subroutine csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_base_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine csgetptn - - subroutine get_neigh(a,idx,neigh,n,info,lev) - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod - implicit none - class(psb_base_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable, intent(out) :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - - integer :: lev_, i, nl, ifl,ill,& - & n1, err_act, nn, nidx,ntl - integer, allocatable :: ia(:), ja(:) - character(len=20) :: name='get_neigh' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if(present(lev)) then - lev_ = lev - else - lev_=1 - end if - ! Turns out we can write get_neigh at this - ! level - n = 0 - call a%csget(idx,idx,n,ia,ja,info) - if (info == 0) call psb_realloc(n,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(1:n) = ja(1:n) - ifl = 1 - ill = n - do nl = 2, lev_ - n1 = ill - ifl + 1 - call psb_ensure_size(ill+n1*n1,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - ntl = 0 - do i=ifl,ill - nidx=neigh(i) - if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then - call a%csget(nidx,nidx,nn,ia,ja,info) - if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) - ntl = ntl+nn - end if - end do - call psb_msort_unique(neigh(ill+1:ill+ntl),nn) - ifl = ill + 1 - ill = ill + nn - end do - call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_) - n = nn - - call psb_erractionrestore(err_act) - return - -9999 continue - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine get_neigh - - subroutine allocate_mnnz(m,n,a,nz) - use psb_error_mod - implicit none - integer, intent(in) :: m,n - class(psb_base_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine allocate_mnnz - - subroutine reallocate_nz(nz,a) - use psb_error_mod - implicit none - integer, intent(in) :: nz - class(psb_base_sparse_mat), intent(inout) :: a - Integer :: err_act - character(len=20) :: name='reallocate_nz' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine reallocate_nz - - subroutine free(a) - use psb_error_mod - implicit none - class(psb_base_sparse_mat), intent(inout) :: a - Integer :: err_act - character(len=20) :: name='free' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine free - - subroutine trim(a) - use psb_error_mod - implicit none - class(psb_base_sparse_mat), intent(inout) :: a - Integer :: err_act - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine trim + end subroutine psb_base_transc_1mat end module psb_base_mat_mod diff --git a/base/modules/psb_c_base_mat_mod.f03 b/base/modules/psb_c_base_mat_mod.f03 index bba4e8b9..a2224b79 100644 --- a/base/modules/psb_c_base_mat_mod.f03 +++ b/base/modules/psb_c_base_mat_mod.f03 @@ -1,54 +1,52 @@ module psb_c_base_mat_mod use psb_base_mat_mod - + type, extends(psb_base_sparse_mat) :: psb_c_base_sparse_mat contains - procedure, pass(a) :: c_base_csmv - procedure, pass(a) :: c_base_csmm - generic, public :: csmm => c_base_csmm, c_base_csmv - procedure, pass(a) :: c_base_cssv - procedure, pass(a) :: c_base_cssm - generic, public :: base_cssm => c_base_cssm, c_base_cssv - procedure, pass(a) :: c_cssv - procedure, pass(a) :: c_cssm - generic, public :: cssm => c_cssm, c_cssv - procedure, pass(a) :: c_scals - procedure, pass(a) :: c_scal - generic, public :: scal => c_scals, c_scal - procedure, pass(a) :: csnmi - procedure, pass(a) :: get_diag - procedure, pass(a) :: csput - - procedure, pass(a) :: c_csgetrow - procedure, pass(a) :: c_csgetblk - generic, public :: csget => c_csgetrow, c_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: cp_to_coo - procedure, pass(a) :: cp_from_coo - procedure, pass(a) :: cp_to_fmt - procedure, pass(a) :: cp_from_fmt - procedure, pass(a) :: mv_to_coo - procedure, pass(a) :: mv_from_coo - procedure, pass(a) :: mv_to_fmt - procedure, pass(a) :: mv_from_fmt + procedure, pass(a) :: c_csmv => psb_c_base_csmv + procedure, pass(a) :: c_csmm => psb_c_base_csmm + generic, public :: csmm => c_csmm, c_csmv + procedure, pass(a) :: c_inner_cssv => psb_c_base_inner_cssv + procedure, pass(a) :: c_inner_cssm => psb_c_base_inner_cssm + generic, public :: inner_cssm => c_inner_cssm, c_inner_cssv + procedure, pass(a) :: c_cssv => psb_c_base_cssv + procedure, pass(a) :: c_cssm => psb_c_base_cssm + generic, public :: cssm => c_cssm, c_cssv + procedure, pass(a) :: c_scals => psb_c_base_scals + procedure, pass(a) :: c_scal => psb_c_base_scal + generic, public :: scal => c_scals, c_scal + procedure, pass(a) :: csnmi => psb_c_base_csnmi + procedure, pass(a) :: get_diag => psb_c_base_get_diag + + procedure, pass(a) :: csput => psb_c_base_csput + procedure, pass(a) :: c_csgetrow => psb_c_base_csgetrow + procedure, pass(a) :: c_csgetblk => psb_c_base_csgetblk + generic, public :: csget => c_csgetrow, c_csgetblk + procedure, pass(a) :: csclip => psb_c_base_csclip + procedure, pass(a) :: cp_to_coo => psb_c_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_c_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_c_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_c_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_c_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_c_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_c_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_c_base_mv_from_fmt procedure, pass(a) :: c_base_cp_from generic, public :: cp_from => c_base_cp_from procedure, pass(a) :: c_base_mv_from generic, public :: mv_from => c_base_mv_from - - procedure, pass(a) :: base_transp_1mat => c_base_transp_1mat - procedure, pass(a) :: base_transp_2mat => c_base_transp_2mat - procedure, pass(a) :: base_transc_1mat => c_base_transc_1mat - procedure, pass(a) :: base_transc_2mat => c_base_transc_2mat + + procedure, pass(a) :: transp_1mat => psb_c_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_c_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_c_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_c_base_transc_2mat + end type psb_c_base_sparse_mat - - private :: c_base_csmv, c_base_csmm, c_base_cssv, c_base_cssm,& - & c_scals, c_scal, csnmi, csput, c_csgetrow, c_csgetblk, & - & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & - & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & - & get_diag, csclip, c_cssv, c_cssm, base_cp_from, base_mv_from - + + private :: c_base_cssv, c_base_cssm, c_base_cp_from, c_base_mv_from + + type, extends(psb_c_base_sparse_mat) :: psb_c_coo_sparse_mat integer :: nnz @@ -57,180 +55,511 @@ module psb_c_base_mat_mod contains - procedure, pass(a) :: get_size => c_coo_get_size - procedure, pass(a) :: get_nzeros => c_coo_get_nzeros - procedure, pass(a) :: set_nzeros => c_coo_set_nzeros - procedure, pass(a) :: c_base_csmm => c_coo_csmm - procedure, pass(a) :: c_base_csmv => c_coo_csmv - procedure, pass(a) :: c_base_cssm => c_coo_cssm - procedure, pass(a) :: c_base_cssv => c_coo_cssv - procedure, pass(a) :: c_scals => c_coo_scals - procedure, pass(a) :: c_scal => c_coo_scal - procedure, pass(a) :: csnmi => c_coo_csnmi - procedure, pass(a) :: csput => c_coo_csput - procedure, pass(a) :: get_diag => c_coo_get_diag - procedure, pass(a) :: reallocate_nz => c_coo_reallocate_nz - procedure, pass(a) :: allocate_mnnz => c_coo_allocate_mnnz - procedure, pass(a) :: cp_to_coo => c_cp_coo_to_coo - procedure, pass(a) :: cp_from_coo => c_cp_coo_from_coo - procedure, pass(a) :: cp_to_fmt => c_cp_coo_to_fmt - procedure, pass(a) :: cp_from_fmt => c_cp_coo_from_fmt - procedure, pass(a) :: mv_to_coo => c_mv_coo_to_coo - procedure, pass(a) :: mv_from_coo => c_mv_coo_from_coo - procedure, pass(a) :: mv_to_fmt => c_mv_coo_to_fmt - procedure, pass(a) :: mv_from_fmt => c_mv_coo_from_fmt - procedure, pass(a) :: fix => c_fix_coo - procedure, pass(a) :: free => c_coo_free - procedure, pass(a) :: trim => c_coo_trim - procedure, pass(a) :: c_csgetrow => c_coo_csgetrow - procedure, pass(a) :: csgetptn => c_coo_csgetptn - procedure, pass(a) :: print => c_coo_print - procedure, pass(a) :: get_fmt => c_coo_get_fmt - procedure, pass(a) :: get_nz_row => c_coo_get_nz_row - procedure, pass(a) :: sizeof => c_coo_sizeof - procedure, pass(a) :: reinit => c_coo_reinit - procedure, pass(a) :: c_coo_cp_from - generic, public :: cp_from => c_coo_cp_from - procedure, pass(a) :: c_coo_mv_from - generic, public :: mv_from => c_coo_mv_from - procedure, pass(a) :: base_transp_1mat => c_coo_transp_1mat - procedure, pass(a) :: base_transc_1mat => c_coo_transc_1mat - + procedure, pass(a) :: get_size => c_coo_get_size + procedure, pass(a) :: get_nzeros => c_coo_get_nzeros + procedure, pass(a) :: set_nzeros => c_coo_set_nzeros + procedure, pass(a) :: get_fmt => c_coo_get_fmt + procedure, pass(a) :: sizeof => c_coo_sizeof + procedure, pass(a) :: c_csmm => psb_c_coo_csmm + procedure, pass(a) :: c_csmv => psb_c_coo_csmv + procedure, pass(a) :: c_inner_cssm => psb_c_coo_cssm + procedure, pass(a) :: c_inner_cssv => psb_c_coo_cssv + procedure, pass(a) :: c_scals => psb_c_coo_scals + procedure, pass(a) :: c_scal => psb_c_coo_scal + procedure, pass(a) :: csnmi => psb_c_coo_csnmi + procedure, pass(a) :: reallocate_nz => psb_c_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_c_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_c_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_c_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_c_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_c_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_c_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_c_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_c_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_c_mv_coo_from_fmt + procedure, pass(a) :: csput => psb_c_coo_csput + procedure, pass(a) :: get_diag => psb_c_coo_get_diag + procedure, pass(a) :: c_csgetrow => psb_c_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_c_coo_csgetptn + procedure, pass(a) :: get_nc_row => psb_c_coo_get_nc_row + procedure, pass(a) :: reinit => psb_c_coo_reinit + procedure, pass(a) :: fix => psb_c_fix_coo + procedure, pass(a) :: trim => psb_c_coo_trim + procedure, pass(a) :: print => psb_c_coo_print + procedure, pass(a) :: free => c_coo_free + procedure, pass(a) :: psb_c_coo_cp_from + generic, public :: cp_from => psb_c_coo_cp_from + procedure, pass(a) :: psb_c_coo_mv_from + generic, public :: mv_from => psb_c_coo_mv_from + procedure, pass(a) :: transp_1mat => c_coo_transp_1mat + procedure, pass(a) :: transc_1mat => c_coo_transc_1mat + end type psb_c_coo_sparse_mat - - private :: c_coo_get_nzeros, c_coo_set_nzeros, c_coo_get_diag, & - & c_coo_csmm, c_coo_csmv, c_coo_cssm, c_coo_cssv, c_coo_csnmi, & - & c_coo_csput, c_coo_reallocate_nz, c_coo_allocate_mnnz, & - & c_fix_coo, c_coo_free, c_coo_print, c_coo_get_fmt, & - & c_cp_coo_to_coo, c_cp_coo_from_coo, & - & c_cp_coo_to_fmt, c_cp_coo_from_fmt, & - & c_coo_scals, c_coo_scal, c_coo_csgetrow, c_coo_sizeof, & - & c_coo_csgetptn, c_coo_get_nz_row, c_coo_reinit,& - & c_coo_cp_from, c_coo_mv_from, & + + private :: c_coo_get_nzeros, c_coo_set_nzeros, & + & c_coo_get_fmt, c_coo_free, c_coo_sizeof, & & c_coo_transp_1mat, c_coo_transc_1mat - + + + + !=================== + ! + ! BASE interfaces + ! + !=================== + + + interface + subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_base_csmm + end interface + + interface + subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_base_csmv + end interface + + interface + subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_base_inner_cssm + end interface + + interface + subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_base_inner_cssv + end interface + + interface + subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_c_base_cssm + end interface + + interface + subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_c_base_cssv + end interface + + interface + subroutine psb_c_base_scals(d,a,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_c_base_scals + end interface + + interface + subroutine psb_c_base_scal(d,a,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_base_scal + end interface + + interface + function psb_c_base_csnmi(a) result(res) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_c_base_csnmi + end interface + + interface + subroutine psb_c_base_get_diag(a,d,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_base_get_diag + end interface + + interface + subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_c_base_csput + end interface + + interface + subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_base_csgetrow + end interface + + interface + subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_base_csgetblk + end interface + + + interface + subroutine psb_c_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_base_csclip + end interface + + + interface + subroutine psb_c_base_cp_to_coo(a,b,info) + import psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_base_cp_to_coo + end interface + + interface + subroutine psb_c_base_cp_from_coo(a,b,info) + import psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_c_base_cp_from_coo + end interface + + interface + subroutine psb_c_base_cp_to_fmt(a,b,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_base_cp_to_fmt + end interface + + interface + subroutine psb_c_base_cp_from_fmt(a,b,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_c_base_cp_from_fmt + end interface + + interface + subroutine psb_c_base_mv_to_coo(a,b,info) + import psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_base_mv_to_coo + end interface + + interface + subroutine psb_c_base_mv_from_coo(a,b,info) + import psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_base_mv_from_coo + end interface + + interface + subroutine psb_c_base_mv_to_fmt(a,b,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_base_mv_to_fmt + end interface + + interface + subroutine psb_c_base_mv_from_fmt(a,b,info) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_base_mv_from_fmt + end interface + + interface + subroutine psb_c_base_transp_2mat(a,b) + import psb_c_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_c_base_transp_2mat + end interface + + interface + subroutine psb_c_base_transc_2mat(a,b) + import psb_c_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_c_base_transc_2mat + end interface + + interface + subroutine psb_c_base_transp_1mat(a) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + end subroutine psb_c_base_transp_1mat + end interface + + interface + subroutine psb_c_base_transc_1mat(a) + import psb_c_base_sparse_mat, psb_spk_ + class(psb_c_base_sparse_mat), intent(inout) :: a + end subroutine psb_c_base_transc_1mat + end interface + + + + + !================= + ! + ! COO interfaces + ! + !================= + + interface + subroutine psb_c_coo_reallocate_nz(nz,a) + import psb_c_coo_sparse_mat + integer, intent(in) :: nz + class(psb_c_coo_sparse_mat), intent(inout) :: a + end subroutine psb_c_coo_reallocate_nz + end interface + + interface + subroutine psb_c_coo_reinit(a,clear) + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_c_coo_reinit + end interface + + interface + subroutine psb_c_coo_trim(a) + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + end subroutine psb_c_coo_trim + end interface + + interface + subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) + import psb_c_coo_sparse_mat + integer, intent(in) :: m,n + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_c_coo_allocate_mnnz + end interface + + interface + subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_c_coo_sparse_mat + integer, intent(in) :: iout + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_c_coo_print + end interface + + + interface + function psb_c_coo_get_nc_row(idx,a) result(res) + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + end function psb_c_coo_get_nc_row + end interface + interface - subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod + subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + import psb_spk_ integer, intent(in) :: nzin,dupl integer, intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) integer, intent(out) :: nzout, info integer, intent(in), optional :: idir - end subroutine c_fix_coo_inner + end subroutine psb_c_fix_coo_inner end interface - + interface - subroutine c_fix_coo_impl(a,info,idir) - use psb_const_mod + subroutine psb_c_fix_coo(a,info,idir) import psb_c_coo_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a integer, intent(out) :: info integer, intent(in), optional :: idir - end subroutine c_fix_coo_impl + end subroutine psb_c_fix_coo end interface - + interface - subroutine c_cp_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_c_cp_coo_to_coo(a,b,info) import psb_c_coo_sparse_mat class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_cp_coo_to_coo_impl + end subroutine psb_c_cp_coo_to_coo end interface interface - subroutine c_cp_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_c_cp_coo_from_coo(a,b,info) import psb_c_coo_sparse_mat - class(psb_c_coo_sparse_mat), intent(out) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine c_cp_coo_from_coo_impl + end subroutine psb_c_cp_coo_from_coo end interface - + interface - subroutine c_cp_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_c_cp_coo_to_fmt(a,b,info) import psb_c_coo_sparse_mat, psb_c_base_sparse_mat class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_cp_coo_to_fmt_impl + end subroutine psb_c_cp_coo_to_fmt end interface - + interface - subroutine c_cp_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_c_cp_coo_from_fmt(a,b,info) import psb_c_coo_sparse_mat, psb_c_base_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine c_cp_coo_from_fmt_impl + end subroutine psb_c_cp_coo_from_fmt end interface - + interface - subroutine c_mv_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_c_mv_coo_to_coo(a,b,info) import psb_c_coo_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_coo_to_coo_impl + end subroutine psb_c_mv_coo_to_coo end interface - + interface - subroutine c_mv_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_c_mv_coo_from_coo(a,b,info) import psb_c_coo_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_coo_from_coo_impl + end subroutine psb_c_mv_coo_from_coo end interface - + interface - subroutine c_mv_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_c_mv_coo_to_fmt(a,b,info) import psb_c_coo_sparse_mat, psb_c_base_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_coo_to_fmt_impl + end subroutine psb_c_mv_coo_to_fmt end interface - + interface - subroutine c_mv_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_c_mv_coo_from_fmt(a,b,info) import psb_c_coo_sparse_mat, psb_c_base_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_coo_from_fmt_impl + end subroutine psb_c_mv_coo_from_fmt end interface - - + interface - subroutine c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_c_coo_sparse_mat + subroutine psb_c_coo_cp_from(a,b) + import psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_coo_sparse_mat), intent(inout) :: a + type(psb_c_coo_sparse_mat), intent(in) :: b + end subroutine psb_c_coo_cp_from + end interface + + interface + subroutine psb_c_coo_mv_from(a,b) + import psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_coo_sparse_mat), intent(inout) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: b + end subroutine psb_c_coo_mv_from + end interface + + + interface + subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer, intent(in) :: nz,ia(:), ja(:),& & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine c_coo_csput_impl + end subroutine psb_c_coo_csput end interface - + interface - subroutine c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_c_coo_sparse_mat - implicit none + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -240,16 +569,13 @@ module psb_c_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine c_coo_csgetptn_impl + end subroutine psb_c_coo_csgetptn end interface interface - subroutine c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_c_coo_sparse_mat - implicit none - + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -260,1205 +586,117 @@ module psb_c_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine c_coo_csgetrow_impl + end subroutine psb_c_coo_csgetrow end interface - interface c_coo_cssm_impl - subroutine c_coo_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_coo_sparse_mat + interface + subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_coo_cssv_impl - subroutine c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_coo_sparse_mat + end subroutine psb_c_coo_cssv + subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_coo_cssm_impl + end subroutine psb_c_coo_cssm end interface - - interface c_coo_csmm_impl - subroutine c_coo_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_coo_sparse_mat + + interface + subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_coo_csmv_impl - subroutine c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_coo_sparse_mat + end subroutine psb_c_coo_csmv + subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_coo_csmm_impl + end subroutine psb_c_coo_csmm end interface - - - interface c_coo_csnmi_impl - function c_coo_csnmi_impl(a) result(res) - use psb_const_mod - import psb_c_coo_sparse_mat + + + interface + function psb_c_coo_csnmi(a) result(res) + import psb_c_coo_sparse_mat, psb_spk_ class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res - end function c_coo_csnmi_impl + end function psb_c_coo_csnmi end interface - - + + interface + subroutine psb_c_coo_get_diag(a,d,info) + import psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_coo_get_diag + end interface + + interface + subroutine psb_c_coo_scal(d,a,info) + import psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_coo_scal + end interface + + interface + subroutine psb_c_coo_scals(d,a,info) + import psb_c_coo_sparse_mat, psb_spk_ + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_c_coo_scals + end interface + + contains - - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - subroutine cp_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_coo - - subroutine cp_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_coo - - - subroutine cp_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_fmt - - subroutine cp_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_fmt - - - subroutine mv_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_coo - - subroutine mv_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_coo - - - subroutine mv_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_fmt - - subroutine mv_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_fmt - + + subroutine c_base_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_base_sparse_mat), intent(out) :: a - type(psb_c_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine c_base_mv_from - - subroutine c_base_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_base_sparse_mat), intent(out) :: a - type(psb_c_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine c_base_cp_from - - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine csput - - subroutine c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_base_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_csgetrow - - - - subroutine c_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csgetblk - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csclip - - - ! - ! Here we go. - ! - subroutine c_coo_transp_1mat(a) - use psb_error_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - - integer, allocatable :: itemp(:) - integer :: info - - call a%psb_c_base_sparse_mat%psb_base_sparse_mat%transp() - call move_alloc(a%ia,itemp) - call move_alloc(a%ja,a%ia) - call move_alloc(itemp,a%ja) - - call a%fix(info) - - return - - end subroutine c_coo_transp_1mat - - subroutine c_coo_transc_1mat(a) - use psb_error_mod implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: a + type(psb_c_base_sparse_mat), intent(inout) :: b - call a%transp() - a%val(:) = conjg(a%val) - - end subroutine c_coo_transc_1mat - - subroutine c_base_transp_2mat(a,b) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - type(psb_c_coo_sparse_mat) :: tmp - integer err_act, info - character(len=*), parameter :: name='c_base_transp' + ! No new things here, very easy + call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - call psb_erractionsave(err_act) - - info = 0 - select type(b) - class is (psb_c_base_sparse_mat) - call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - class default - info = 700 - end select - if (info /= 0) then - call psb_errpush(info,name,a_err=b%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - end subroutine c_base_transp_2mat - - subroutine c_base_transc_2mat(a,b) - use psb_error_mod + end subroutine c_base_mv_from + + subroutine c_base_cp_from(a,b) implicit none class(psb_c_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - type(psb_c_coo_sparse_mat) :: tmp - integer err_act, info - character(len=*), parameter :: name='c_base_transc' - - call psb_erractionsave(err_act) - - - info = 0 - select type(b) - class is (psb_c_base_sparse_mat) - call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transc() - if (info == 0) call a%mv_from_coo(tmp,info) - class default - info = 700 - end select - if (info /= 0) then - call psb_errpush(info,name,a_err=b%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - end subroutine c_base_transc_2mat - - subroutine c_base_transp_1mat(a) - use psb_error_mod - implicit none - - class(psb_c_base_sparse_mat), intent(inout) :: a - - type(psb_c_coo_sparse_mat) :: tmp - integer :: err_act, info - character(len=*), parameter :: name='c_base_transp' - - call psb_erractionsave(err_act) - info = 0 - call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - - if (info /= 0) then - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - - - end subroutine c_base_transp_1mat - - subroutine c_base_transc_1mat(a) - use psb_error_mod - implicit none - - class(psb_c_base_sparse_mat), intent(inout) :: a - - type(psb_c_coo_sparse_mat) :: tmp - integer :: err_act, info - character(len=*), parameter :: name='c_base_transc' - - call psb_erractionsave(err_act) - info = 0 - call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transc() - if (info == 0) call a%mv_from_coo(tmp,info) - - if (info /= 0) then - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - - - end subroutine c_base_transc_1mat - - - - - !==================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !==================================== - - subroutine c_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_base_csmm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_base_csmm - - subroutine c_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_base_csmv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine c_base_csmv - - subroutine c_base_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_base_cssm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_base_cssm - - subroutine c_base_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_base_cssv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_base_cssv - - subroutine c_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - - complex(psb_spk_), allocatable :: tmp(:,:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='c_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(cone,x,czero,tmp,info,trans) - - if (info == 0)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == 0)& - & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine c_cssm - - subroutine c_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - - complex(psb_spk_), allocatable :: tmp(:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='c_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) tmp(1:nac) = d(1:nac)*x(1:nac) - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(cone,x,czero,tmp,info,trans) - - if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar) - if (info == 0)& - & call psb_geaxpby(nar,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine c_cssv - - - subroutine c_scals(d,a,info) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='c_scals' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_scals - - - subroutine c_scal(d,a,info) - use psb_error_mod - implicit none - class(psb_c_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='c_scal' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_scal - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = -sone - - return - - end function csnmi - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - + type(psb_c_base_sparse_mat), intent(in) :: b + + ! No new things here, very easy + call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) + return - - end subroutine get_diag - - - - + + end subroutine c_base_cp_from + + + !==================================== ! ! @@ -1470,35 +708,35 @@ contains ! ! !==================================== - - + + function c_coo_sizeof(a) result(res) implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 + 1 - res = res + 2*psb_sizeof_sp * size(a%val) + res = res + 2 * psb_sizeof_sp * size(a%val) res = res + psb_sizeof_int * size(a%ia) res = res + psb_sizeof_int * size(a%ja) - + end function c_coo_sizeof - - + + function c_coo_get_fmt(a) result(res) implicit none class(psb_c_coo_sparse_mat), intent(in) :: a character(len=5) :: res res = 'COO' end function c_coo_get_fmt - - + + function c_coo_get_size(a) result(res) implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) if (allocated(a%ja)) then if (res >= 0) then @@ -1515,66 +753,16 @@ contains end if end if end function c_coo_get_size - - + + function c_coo_get_nzeros(a) result(res) implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer :: res res = a%nnz end function c_coo_get_nzeros - - - function c_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - implicit none - - class(psb_c_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer :: res - integer :: nzin_, nza,ip,jp,i,k - - res = 0 - nza = a%get_nzeros() - if (a%is_sorted()) then - ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - - end function c_coo_get_nz_row - + + !==================================== ! ! @@ -1587,807 +775,49 @@ contains ! ! !==================================== - + subroutine c_coo_set_nzeros(nz,a) - implicit none - integer, intent(in) :: nz - class(psb_c_coo_sparse_mat), intent(inout) :: a - - a%nnz = nz - - end subroutine c_coo_set_nzeros - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - - subroutine c_fix_coo(a,info,idir) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: idir - Integer :: err_act - character(len=20) :: name='fix_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_fix_coo_impl(a,info,idir) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine c_fix_coo - - - subroutine c_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_coo_to_coo - - subroutine c_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(out) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_coo_from_coo - - - subroutine c_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_coo_to_fmt - - subroutine c_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_coo_from_fmt - - - - subroutine c_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_coo_to_coo - - subroutine c_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_coo_from_coo - - - - subroutine c_coo_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_coo_sparse_mat), intent(out) :: a - type(psb_c_coo_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_coo_cp_from - - subroutine c_coo_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_coo_sparse_mat), intent(out) :: a - type(psb_c_coo_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_coo_mv_from - - - subroutine c_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_coo_to_fmt - - subroutine c_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_coo_from_fmt - - - - subroutine c_coo_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_c_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='c_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,a%ja,a%val,info) - - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_reallocate_nz - - - subroutine c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='c_coo_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - nza = a%get_nzeros() - call c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_csput - - - subroutine c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + implicit none + integer, intent(in) :: nz + class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_csgetrow - - - subroutine c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + a%nnz = nz - class(psb_c_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_csgetptn - - + end subroutine c_coo_set_nzeros + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + + subroutine c_coo_free(a) implicit none - + class(psb_c_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() call a%set_nrows(0) call a%set_ncols(0) - + call a%set_nzeros(0) + return - + end subroutine c_coo_free - - subroutine c_coo_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_c_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = czero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_reinit - - - subroutine c_coo_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_trim - - subroutine c_coo_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_c_coo_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nc_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nc_ = nz - else - nc_ = max(7*m,7*n,1) - end if - if (nc_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - if (info == 0) call psb_realloc(nc_,a%ia,info) - if (info == 0) call psb_realloc(nc_,a%ja,info) - if (info == 0) call psb_realloc(nc_,a%val,info) - if (info == 0) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(0) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - end if - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_allocate_mnnz - - - subroutine c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_c_coo_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='c_coo_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - - end subroutine c_coo_print - - - - + + + !==================================== ! ! @@ -2400,381 +830,36 @@ contains ! ! !==================================== - - subroutine c_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod + subroutine c_coo_transp_1mat(a) implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nac, nar - complex(psb_spk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='c_coo_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - call c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_csmv - - subroutine c_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - complex(psb_spk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='c_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + class(psb_c_coo_sparse_mat), intent(inout) :: a - call c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_csmm - - - subroutine c_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nar, nac - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='c_coo_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + integer, allocatable :: itemp(:) + integer :: info - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine c_coo_cssv - - - - subroutine c_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='c_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + call a%psb_c_base_sparse_mat%psb_base_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%fix(info) - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_cssm - - function c_coo_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = c_coo_csnmi_impl(a) - - return - - end function c_coo_csnmi - - subroutine c_coo_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = czero - - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_coo_get_diag - - subroutine c_coo_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine c_coo_scal - - subroutine c_coo_scals(d,a,info) - use psb_error_mod - use psb_const_mod + + end subroutine c_coo_transp_1mat + + subroutine c_coo_transc_1mat(a) + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return + + call a%transp() + a%val(:) = conjg(a%val) -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + end subroutine c_coo_transc_1mat - end subroutine c_coo_scals end module psb_c_base_mat_mod diff --git a/base/modules/psb_c_csc_mat_mod.f03 b/base/modules/psb_c_csc_mat_mod.f03 index e78ed3db..2446f6de 100644 --- a/base/modules/psb_c_csc_mat_mod.f03 +++ b/base/modules/psb_c_csc_mat_mod.f03 @@ -8,161 +8,195 @@ module psb_c_csc_mat_mod complex(psb_spk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => c_csc_get_nzeros - procedure, pass(a) :: get_fmt => c_csc_get_fmt - procedure, pass(a) :: get_diag => c_csc_get_diag - procedure, pass(a) :: c_base_csmm => c_csc_csmm - procedure, pass(a) :: c_base_csmv => c_csc_csmv - procedure, pass(a) :: c_base_cssm => c_csc_cssm - procedure, pass(a) :: c_base_cssv => c_csc_cssv - procedure, pass(a) :: c_scals => c_csc_scals - procedure, pass(a) :: c_scal => c_csc_scal - procedure, pass(a) :: csnmi => c_csc_csnmi - procedure, pass(a) :: reallocate_nz => c_csc_reallocate_nz - procedure, pass(a) :: csput => c_csc_csput - procedure, pass(a) :: allocate_mnnz => c_csc_allocate_mnnz - procedure, pass(a) :: cp_to_coo => c_cp_csc_to_coo - procedure, pass(a) :: cp_from_coo => c_cp_csc_from_coo - procedure, pass(a) :: cp_to_fmt => c_cp_csc_to_fmt - procedure, pass(a) :: cp_from_fmt => c_cp_csc_from_fmt - procedure, pass(a) :: mv_to_coo => c_mv_csc_to_coo - procedure, pass(a) :: mv_from_coo => c_mv_csc_from_coo - procedure, pass(a) :: mv_to_fmt => c_mv_csc_to_fmt - procedure, pass(a) :: mv_from_fmt => c_mv_csc_from_fmt - procedure, pass(a) :: csgetptn => c_csc_csgetptn - procedure, pass(a) :: c_csgetrow => c_csc_csgetrow - procedure, pass(a) :: get_size => c_csc_get_size - procedure, pass(a) :: free => c_csc_free - procedure, pass(a) :: trim => c_csc_trim - procedure, pass(a) :: print => c_csc_print - procedure, pass(a) :: sizeof => c_csc_sizeof - procedure, pass(a) :: reinit => c_csc_reinit - procedure, pass(a) :: c_csc_cp_from - generic, public :: cp_from => c_csc_cp_from - procedure, pass(a) :: c_csc_mv_from - generic, public :: mv_from => c_csc_mv_from - end type psb_c_csc_sparse_mat + procedure, pass(a) :: get_size => c_csc_get_size + procedure, pass(a) :: get_nzeros => c_csc_get_nzeros + procedure, pass(a) :: get_fmt => c_csc_get_fmt + procedure, pass(a) :: sizeof => c_csc_sizeof + procedure, pass(a) :: c_csmm => psb_c_csc_csmm + procedure, pass(a) :: c_csmv => psb_c_csc_csmv + procedure, pass(a) :: c_inner_cssm => psb_c_csc_cssm + procedure, pass(a) :: c_inner_cssv => psb_c_csc_cssv + procedure, pass(a) :: c_scals => psb_c_csc_scals + procedure, pass(a) :: c_scal => psb_c_csc_scal + procedure, pass(a) :: csnmi => psb_c_csc_csnmi + procedure, pass(a) :: reallocate_nz => psb_c_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_c_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_c_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_c_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_c_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_c_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_c_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_c_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_c_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_c_mv_csc_from_fmt + procedure, pass(a) :: csput => psb_c_csc_csput + procedure, pass(a) :: get_diag => psb_c_csc_get_diag + procedure, pass(a) :: csgetptn => psb_c_csc_csgetptn + procedure, pass(a) :: c_csgetrow => psb_c_csc_csgetrow + procedure, pass(a) :: get_nc_col => c_csc_get_nc_col + procedure, pass(a) :: reinit => psb_c_csc_reinit + procedure, pass(a) :: trim => psb_c_csc_trim + procedure, pass(a) :: print => psb_c_csc_print + procedure, pass(a) :: free => c_csc_free + procedure, pass(a) :: psb_c_csc_cp_from + generic, public :: cp_from => psb_c_csc_cp_from + procedure, pass(a) :: psb_c_csc_mv_from + generic, public :: mv_from => psb_c_csc_mv_from - private :: c_csc_get_nzeros, c_csc_csmm, c_csc_csmv, c_csc_cssm, c_csc_cssv, & - & c_csc_csput, c_csc_reallocate_nz, c_csc_allocate_mnnz, & - & c_csc_free, c_csc_print, c_csc_get_fmt, c_csc_csnmi, get_diag, & - & c_cp_csc_to_coo, c_cp_csc_from_coo, & - & c_mv_csc_to_coo, c_mv_csc_from_coo, & - & c_cp_csc_to_fmt, c_cp_csc_from_fmt, & - & c_mv_csc_to_fmt, c_mv_csc_from_fmt, & - & c_csc_scals, c_csc_scal, c_csc_trim, c_csc_csgetrow, c_csc_get_size, & - & c_csc_sizeof, c_csc_csgetptn, c_csc_get_nz_row, c_csc_reinit + end type psb_c_csc_sparse_mat + private :: c_csc_get_nzeros, c_csc_free, c_csc_get_fmt, & + & c_csc_get_size, c_csc_sizeof, c_csc_get_nc_col - interface - subroutine c_cp_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod + interface + subroutine psb_c_csc_reallocate_nz(nz,a) import psb_c_csc_sparse_mat - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine c_cp_csc_to_fmt_impl + integer, intent(in) :: nz + class(psb_c_csc_sparse_mat), intent(inout) :: a + end subroutine psb_c_csc_reallocate_nz end interface - + interface - subroutine c_cp_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod + subroutine psb_c_csc_reinit(a,clear) + import psb_c_csc_sparse_mat + class(psb_c_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_c_csc_reinit + end interface + + interface + subroutine psb_c_csc_trim(a) import psb_c_csc_sparse_mat class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine c_cp_csc_from_fmt_impl + end subroutine psb_c_csc_trim end interface - - - interface - subroutine c_cp_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod + + interface + subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) import psb_c_csc_sparse_mat + integer, intent(in) :: m,n + class(psb_c_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_c_csc_allocate_mnnz + end interface + + interface + subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_c_csc_sparse_mat + integer, intent(in) :: iout + class(psb_c_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_c_csc_print + end interface + + interface + subroutine psb_c_cp_csc_to_coo(a,b,info) + import psb_c_coo_sparse_mat, psb_c_csc_sparse_mat class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_cp_csc_to_coo_impl + end subroutine psb_c_cp_csc_to_coo end interface - + interface - subroutine c_cp_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csc_sparse_mat + subroutine psb_c_cp_csc_from_coo(a,b,info) + import psb_c_csc_sparse_mat, psb_c_coo_sparse_mat class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine c_cp_csc_from_coo_impl + end subroutine psb_c_cp_csc_from_coo end interface - + interface - subroutine c_mv_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csc_sparse_mat + subroutine psb_c_cp_csc_to_fmt(a,b,info) + import psb_c_csc_sparse_mat, psb_c_base_sparse_mat + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_cp_csc_to_fmt + end interface + + interface + subroutine psb_c_cp_csc_from_fmt(a,b,info) + import psb_c_csc_sparse_mat, psb_c_base_sparse_mat + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_c_cp_csc_from_fmt + end interface + + interface + subroutine psb_c_mv_csc_to_coo(a,b,info) + import psb_c_csc_sparse_mat, psb_c_coo_sparse_mat class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_csc_to_fmt_impl + end subroutine psb_c_mv_csc_to_coo end interface - + interface - subroutine c_mv_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csc_sparse_mat + subroutine psb_c_mv_csc_from_coo(a,b,info) + import psb_c_csc_sparse_mat, psb_c_coo_sparse_mat + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_mv_csc_from_coo + end interface + + interface + subroutine psb_c_mv_csc_to_fmt(a,b,info) + import psb_c_csc_sparse_mat, psb_c_base_sparse_mat + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_mv_csc_to_fmt + end interface + + interface + subroutine psb_c_mv_csc_from_fmt(a,b,info) + import psb_c_csc_sparse_mat, psb_c_base_sparse_mat class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_csc_from_fmt_impl + end subroutine psb_c_mv_csc_from_fmt end interface - - + interface - subroutine c_mv_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csc_sparse_mat + subroutine psb_c_csc_cp_from(a,b) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine c_mv_csc_to_coo_impl + type(psb_c_csc_sparse_mat), intent(in) :: b + end subroutine psb_c_csc_cp_from end interface - + interface - subroutine c_mv_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csc_sparse_mat - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine c_mv_csc_from_coo_impl + subroutine psb_c_csc_mv_from(a,b) + import psb_c_csc_sparse_mat, psb_spk_ + class(psb_c_csc_sparse_mat), intent(inout) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: b + end subroutine psb_c_csc_mv_from end interface - + + interface - subroutine c_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_c_csc_sparse_mat + subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine c_csc_csput_impl + end subroutine psb_c_csc_csput end interface - + interface - subroutine c_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_c_csc_sparse_mat - implicit none - + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -172,16 +206,13 @@ module psb_c_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine c_csc_csgetptn_impl + end subroutine psb_c_csc_csgetptn end interface - + interface - subroutine c_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_c_csc_sparse_mat - implicit none - + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -192,61 +223,98 @@ module psb_c_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine c_csc_csgetrow_impl + end subroutine psb_c_csc_csgetrow end interface - interface c_csc_cssm_impl - subroutine c_csc_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csc_sparse_mat + interface + subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_c_csc_sparse_mat, psb_spk_, psb_c_coo_sparse_mat + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csc_csgetblk + end interface + + interface + subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csc_cssv_impl - subroutine c_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csc_sparse_mat + end subroutine psb_c_csc_cssv + subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csc_cssm_impl + end subroutine psb_c_csc_cssm end interface - - interface c_csc_csmm_impl - subroutine c_csc_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csc_sparse_mat + + interface + subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csc_csmv_impl - subroutine c_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csc_sparse_mat + end subroutine psb_c_csc_csmv + subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csc_csmm_impl + end subroutine psb_c_csc_csmm end interface - - interface c_csc_csnmi_impl - function c_csc_csnmi_impl(a) result(res) - use psb_const_mod - import psb_c_csc_sparse_mat + + + interface + function psb_c_csc_csnmi(a) result(res) + import psb_c_csc_sparse_mat, psb_spk_ class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res - end function c_csc_csnmi_impl + end function psb_c_csc_csnmi + end interface + + interface + subroutine psb_c_csc_get_diag(a,d,info) + import psb_c_csc_sparse_mat, psb_spk_ + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_csc_get_diag + end interface + + interface + subroutine psb_c_csc_scal(d,a,info) + import psb_c_csc_sparse_mat, psb_spk_ + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_csc_scal + end interface + + interface + subroutine psb_c_csc_scals(d,a,info) + import psb_c_csc_sparse_mat, psb_spk_ + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_c_csc_scals end interface - contains @@ -268,7 +336,7 @@ contains class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 - res = res + 2*psb_sizeof_sp * size(a%val) + res = res + 2 * psb_sizeof_sp * size(a%val) res = res + psb_sizeof_int * size(a%icp) res = res + psb_sizeof_int * size(a%ia) @@ -314,7 +382,7 @@ contains - function c_csc_get_nz_col(idx,a) result(res) + function c_csc_get_nc_col(idx,a) result(res) use psb_const_mod implicit none @@ -328,7 +396,7 @@ contains res = a%icp(idx+1)-a%icp(idx) end if - end function c_csc_get_nz_col + end function c_csc_get_nc_col @@ -345,339 +413,6 @@ contains !===================================== - subroutine c_csc_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_c_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='c_csc_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_reallocate_nz - - subroutine c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='c_csc_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call c_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_csc_csput - - subroutine c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call c_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_csgetptn - - - subroutine c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call c_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_csgetrow - - - subroutine c_csc_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_csgetblk - - - subroutine c_csc_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_csclip - - subroutine c_csc_free(a) implicit none @@ -694,886 +429,4 @@ contains end subroutine c_csc_free - subroutine c_csc_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = szero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_reinit - - subroutine c_csc_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, n - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - n = a%get_ncols() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_trim - - subroutine c_cp_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_to_coo - - subroutine c_cp_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_from_coo - - - subroutine c_cp_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_to_fmt - - subroutine c_cp_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_from_fmt - - - subroutine c_mv_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_to_coo - - subroutine c_mv_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_from_coo - - - subroutine c_mv_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_to_fmt - - subroutine c_mv_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_from_fmt - - subroutine c_csc_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_c_csc_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%icp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_allocate_mnnz - - - subroutine c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_c_csc_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='c_csc_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),(i),a%val(j) - end do - enddo - endif - endif - - end subroutine c_csc_print - - - subroutine c_csc_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(out) :: a - type(psb_c_csc_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) - a%icp = b%icp - a%ia = b%ia - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_csc_cp_from - - subroutine c_csc_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_csc_sparse_mat), intent(out) :: a - type(psb_c_csc_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_csc_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine c_csc_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_csc_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call c_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_csmv - - subroutine c_csc_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - logical :: tra - Integer :: err_act - character(len=20) :: name='c_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call c_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_csmm - - - subroutine c_csc_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_csc_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call c_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine c_csc_cssv - - - - subroutine c_csc_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='c_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call c_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_cssm - - function c_csc_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = c_csc_csnmi_impl(a) - - return - - end function c_csc_csnmi - - subroutine c_csc_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = szero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_get_diag - - - subroutine c_csc_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, n - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - n = a%get_ncols() - if (size(d) < n) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, n - do j = a%icp(i), a%icp(i+1) -1 - a%val(j) = a%val(j) * d(a%ia(j)) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_scal - - - subroutine c_csc_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csc_scals - - - end module psb_c_csc_mat_mod diff --git a/base/modules/psb_c_csr_mat_mod.f03 b/base/modules/psb_c_csr_mat_mod.f03 index db049777..f0efef1f 100644 --- a/base/modules/psb_c_csr_mat_mod.f03 +++ b/base/modules/psb_c_csr_mat_mod.f03 @@ -8,165 +8,195 @@ module psb_c_csr_mat_mod complex(psb_spk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => c_csr_get_nzeros - procedure, pass(a) :: get_fmt => c_csr_get_fmt - procedure, pass(a) :: get_diag => c_csr_get_diag - procedure, pass(a) :: c_base_csmm => c_csr_csmm - procedure, pass(a) :: c_base_csmv => c_csr_csmv - procedure, pass(a) :: c_base_cssm => c_csr_cssm - procedure, pass(a) :: c_base_cssv => c_csr_cssv - procedure, pass(a) :: c_scals => c_csr_scals - procedure, pass(a) :: c_scal => c_csr_scal - procedure, pass(a) :: csnmi => c_csr_csnmi - procedure, pass(a) :: reallocate_nz => c_csr_reallocate_nz - procedure, pass(a) :: csput => c_csr_csput - procedure, pass(a) :: allocate_mnnz => c_csr_allocate_mnnz - procedure, pass(a) :: cp_to_coo => c_cp_csr_to_coo - procedure, pass(a) :: cp_from_coo => c_cp_csr_from_coo - procedure, pass(a) :: cp_to_fmt => c_cp_csr_to_fmt - procedure, pass(a) :: cp_from_fmt => c_cp_csr_from_fmt - procedure, pass(a) :: mv_to_coo => c_mv_csr_to_coo - procedure, pass(a) :: mv_from_coo => c_mv_csr_from_coo - procedure, pass(a) :: mv_to_fmt => c_mv_csr_to_fmt - procedure, pass(a) :: mv_from_fmt => c_mv_csr_from_fmt - procedure, pass(a) :: csgetptn => c_csr_csgetptn - procedure, pass(a) :: c_csgetrow => c_csr_csgetrow - procedure, pass(a) :: get_nz_row => c_csr_get_nz_row - procedure, pass(a) :: get_size => c_csr_get_size - procedure, pass(a) :: free => c_csr_free - procedure, pass(a) :: trim => c_csr_trim - procedure, pass(a) :: print => c_csr_print - procedure, pass(a) :: sizeof => c_csr_sizeof - procedure, pass(a) :: reinit => c_csr_reinit - procedure, pass(a) :: c_csr_cp_from - generic, public :: cp_from => c_csr_cp_from - procedure, pass(a) :: c_csr_mv_from - generic, public :: mv_from => c_csr_mv_from + procedure, pass(a) :: get_size => c_csr_get_size + procedure, pass(a) :: get_nzeros => c_csr_get_nzeros + procedure, pass(a) :: get_fmt => c_csr_get_fmt + procedure, pass(a) :: sizeof => c_csr_sizeof + procedure, pass(a) :: c_csmm => psb_c_csr_csmm + procedure, pass(a) :: c_csmv => psb_c_csr_csmv + procedure, pass(a) :: c_inner_cssm => psb_c_csr_cssm + procedure, pass(a) :: c_inner_cssv => psb_c_csr_cssv + procedure, pass(a) :: c_scals => psb_c_csr_scals + procedure, pass(a) :: c_scal => psb_c_csr_scal + procedure, pass(a) :: csnmi => psb_c_csr_csnmi + procedure, pass(a) :: reallocate_nz => psb_c_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_c_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_c_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_c_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_c_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_c_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_c_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_c_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_c_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_c_mv_csr_from_fmt + procedure, pass(a) :: csput => psb_c_csr_csput + procedure, pass(a) :: get_diag => psb_c_csr_get_diag + procedure, pass(a) :: csgetptn => psb_c_csr_csgetptn + procedure, pass(a) :: c_csgetrow => psb_c_csr_csgetrow + procedure, pass(a) :: get_nc_row => c_csr_get_nc_row + procedure, pass(a) :: reinit => psb_c_csr_reinit + procedure, pass(a) :: trim => psb_c_csr_trim + procedure, pass(a) :: print => psb_c_csr_print + procedure, pass(a) :: free => c_csr_free + procedure, pass(a) :: psb_c_csr_cp_from + generic, public :: cp_from => psb_c_csr_cp_from + procedure, pass(a) :: psb_c_csr_mv_from + generic, public :: mv_from => psb_c_csr_mv_from end type psb_c_csr_sparse_mat - private :: c_csr_get_nzeros, c_csr_csmm, c_csr_csmv, c_csr_cssm, c_csr_cssv, & - & c_csr_csput, c_csr_reallocate_nz, c_csr_allocate_mnnz, & - & c_csr_free, c_csr_print, c_csr_get_fmt, c_csr_csnmi, get_diag, & - & c_cp_csr_to_coo, c_cp_csr_from_coo, & - & c_mv_csr_to_coo, c_mv_csr_from_coo, & - & c_cp_csr_to_fmt, c_cp_csr_from_fmt, & - & c_mv_csr_to_fmt, c_mv_csr_from_fmt, & - & c_csr_scals, c_csr_scal, c_csr_trim, c_csr_csgetrow, c_csr_get_size, & - & c_csr_sizeof, c_csr_csgetptn, c_csr_get_nz_row, c_csr_reinit -!!$, & -!!$ & c_csr_mv_from, c_csr_mv_from + private :: c_csr_get_nzeros, c_csr_free, c_csr_get_fmt, & + & c_csr_get_size, c_csr_sizeof, c_csr_get_nc_row - - interface - subroutine c_cp_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod + interface + subroutine psb_c_csr_reallocate_nz(nz,a) import psb_c_csr_sparse_mat - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine c_cp_csr_to_fmt_impl + integer, intent(in) :: nz + class(psb_c_csr_sparse_mat), intent(inout) :: a + end subroutine psb_c_csr_reallocate_nz end interface - + interface - subroutine c_cp_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod + subroutine psb_c_csr_reinit(a,clear) + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_c_csr_reinit + end interface + + interface + subroutine psb_c_csr_trim(a) import psb_c_csr_sparse_mat class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine c_cp_csr_from_fmt_impl + end subroutine psb_c_csr_trim end interface - - - interface - subroutine c_cp_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod + + interface + subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) + import psb_c_csr_sparse_mat + integer, intent(in) :: m,n + class(psb_c_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_c_csr_allocate_mnnz + end interface + + interface + subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) import psb_c_csr_sparse_mat + integer, intent(in) :: iout + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_c_csr_print + end interface + + interface + subroutine psb_c_cp_csr_to_coo(a,b,info) + import psb_c_coo_sparse_mat, psb_c_csr_sparse_mat class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_cp_csr_to_coo_impl + end subroutine psb_c_cp_csr_to_coo end interface - + interface - subroutine c_cp_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csr_sparse_mat + subroutine psb_c_cp_csr_from_coo(a,b,info) + import psb_c_csr_sparse_mat, psb_c_coo_sparse_mat class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine c_cp_csr_from_coo_impl + end subroutine psb_c_cp_csr_from_coo end interface - + interface - subroutine c_mv_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csr_sparse_mat + subroutine psb_c_cp_csr_to_fmt(a,b,info) + import psb_c_csr_sparse_mat, psb_c_base_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_cp_csr_to_fmt + end interface + + interface + subroutine psb_c_cp_csr_from_fmt(a,b,info) + import psb_c_csr_sparse_mat, psb_c_base_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_c_cp_csr_from_fmt + end interface + + interface + subroutine psb_c_mv_csr_to_coo(a,b,info) + import psb_c_csr_sparse_mat, psb_c_coo_sparse_mat class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_csr_to_fmt_impl + end subroutine psb_c_mv_csr_to_coo end interface - + interface - subroutine c_mv_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csr_sparse_mat + subroutine psb_c_mv_csr_from_coo(a,b,info) + import psb_c_csr_sparse_mat, psb_c_coo_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_mv_csr_from_coo + end interface + + interface + subroutine psb_c_mv_csr_to_fmt(a,b,info) + import psb_c_csr_sparse_mat, psb_c_base_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_c_mv_csr_to_fmt + end interface + + interface + subroutine psb_c_mv_csr_from_fmt(a,b,info) + import psb_c_csr_sparse_mat, psb_c_base_sparse_mat class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine c_mv_csr_from_fmt_impl + end subroutine psb_c_mv_csr_from_fmt end interface - - + interface - subroutine c_mv_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csr_sparse_mat + subroutine psb_c_csr_cp_from(a,b) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine c_mv_csr_to_coo_impl + type(psb_c_csr_sparse_mat), intent(in) :: b + end subroutine psb_c_csr_cp_from end interface - + interface - subroutine c_mv_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_c_base_mat_mod - import psb_c_csr_sparse_mat - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine c_mv_csr_from_coo_impl + subroutine psb_c_csr_mv_from(a,b) + import psb_c_csr_sparse_mat, psb_spk_ + class(psb_c_csr_sparse_mat), intent(inout) :: a + type(psb_c_csr_sparse_mat), intent(inout) :: b + end subroutine psb_c_csr_mv_from end interface - + + interface - subroutine c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_c_csr_sparse_mat + subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine c_csr_csput_impl + end subroutine psb_c_csr_csput end interface - + interface - subroutine c_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_c_csr_sparse_mat - implicit none - + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -176,16 +206,13 @@ module psb_c_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine c_csr_csgetptn_impl + end subroutine psb_c_csr_csgetptn end interface - + interface - subroutine c_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_c_csr_sparse_mat - implicit none - + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -196,58 +223,96 @@ module psb_c_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine c_csr_csgetrow_impl + end subroutine psb_c_csr_csgetrow end interface - interface c_csr_cssm_impl - subroutine c_csr_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csr_sparse_mat + interface + subroutine psb_c_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_c_csr_sparse_mat, psb_spk_, psb_c_coo_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csr_csgetblk + end interface + + interface + subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csr_cssv_impl - subroutine c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csr_sparse_mat + end subroutine psb_c_csr_cssv + subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csr_cssm_impl + end subroutine psb_c_csr_cssm end interface - - interface c_csr_csmm_impl - subroutine c_csr_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csr_sparse_mat + + interface + subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csr_csmv_impl - subroutine c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_c_csr_sparse_mat + end subroutine psb_c_csr_csmv + subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine c_csr_csmm_impl + end subroutine psb_c_csr_csmm end interface - - interface c_csr_csnmi_impl - function c_csr_csnmi_impl(a) result(res) - use psb_const_mod - import psb_c_csr_sparse_mat + + + interface + function psb_c_csr_csnmi(a) result(res) + import psb_c_csr_sparse_mat, psb_spk_ class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - end function c_csr_csnmi_impl + end function psb_c_csr_csnmi + end interface + + interface + subroutine psb_c_csr_get_diag(a,d,info) + import psb_c_csr_sparse_mat, psb_spk_ + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_csr_get_diag + end interface + + interface + subroutine psb_c_csr_scal(d,a,info) + import psb_c_csr_sparse_mat, psb_spk_ + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_csr_scal + end interface + + interface + subroutine psb_c_csr_scals(d,a,info) + import psb_c_csr_sparse_mat, psb_spk_ + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_c_csr_scals end interface @@ -272,7 +337,7 @@ contains class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 - res = res + 2*psb_sizeof_sp * size(a%val) + res = res + 2 * psb_sizeof_sp * size(a%val) res = res + psb_sizeof_int * size(a%irp) res = res + psb_sizeof_int * size(a%ja) @@ -318,8 +383,8 @@ contains - function c_csr_get_nz_row(idx,a) result(res) - use psb_const_mod + function c_csr_get_nc_row(idx,a) result(res) + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a @@ -332,7 +397,7 @@ contains res = a%irp(idx+1)-a%irp(idx) end if - end function c_csr_get_nz_row + end function c_csr_get_nc_row @@ -348,341 +413,6 @@ contains ! !===================================== - - subroutine c_csr_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_c_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='c_csr_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& - & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_reallocate_nz - - subroutine c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='c_csr_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_csr_csput - - subroutine c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call c_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_csgetptn - - - subroutine c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call c_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_csgetrow - - - subroutine c_csr_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_csgetblk - - - subroutine c_csr_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_csclip - - subroutine c_csr_free(a) implicit none @@ -699,906 +429,5 @@ contains end subroutine c_csr_free - subroutine c_csr_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = czero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_reinit - - - subroutine c_csr_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, m - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - m = a%get_nrows() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_trim - - - subroutine c_cp_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csr_to_coo - - subroutine c_cp_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csr_from_coo - - - subroutine c_cp_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csr_to_fmt - - subroutine c_cp_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csr_from_fmt - - - subroutine c_mv_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csr_to_coo - - subroutine c_mv_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csr_from_coo - - - subroutine c_mv_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csr_to_fmt - - subroutine c_mv_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csr_from_fmt - - - subroutine c_csr_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_c_csr_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nc_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nc_ = nz - else - nc_ = max(7*m,7*n,1) - end if - if (nc_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nc_,a%ja,info) - if (info == 0) call psb_realloc(nc_,a%val,info) - if (info == 0) then - a%irp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_allocate_mnnz - - - subroutine c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_c_csr_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='c_csr_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),(a%ja(j)),a%val(j) - end do - enddo - endif - endif - - end subroutine c_csr_print - - - subroutine c_csr_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(out) :: a - type(psb_c_csr_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) - a%irp = b%irp - a%ja = b%ja - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_csr_cp_from - - subroutine c_csr_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_c_csr_sparse_mat), intent(out) :: a - type(psb_c_csr_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_csr_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine c_csr_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - complex(psb_spk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='c_csr_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_csmv - - subroutine c_csr_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='c_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_csmm - - - subroutine c_csr_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='c_csr_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine c_csr_cssv - - - - subroutine c_csr_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='c_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_cssm - - function c_csr_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = c_csr_csnmi_impl(a) - - return - - end function c_csr_csnmi - - subroutine c_csr_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = czero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_get_diag - - - subroutine c_csr_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 - a%val(j) = a%val(j) * d(i) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_scal - - - subroutine c_csr_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csr_scals - - end module psb_c_csr_mat_mod diff --git a/base/modules/psb_c_mat_mod.f03 b/base/modules/psb_c_mat_mod.f03 index 07ccb434..60a17466 100644 --- a/base/modules/psb_c_mat_mod.f03 +++ b/base/modules/psb_c_mat_mod.f03 @@ -9,20 +9,6 @@ module psb_c_mat_mod class(psb_c_base_sparse_mat), allocatable :: a contains - ! Setters - procedure, pass(a) :: set_nrows - procedure, pass(a) :: set_ncols - procedure, pass(a) :: set_dupl - procedure, pass(a) :: set_state - procedure, pass(a) :: set_null - procedure, pass(a) :: set_bld - procedure, pass(a) :: set_upd - procedure, pass(a) :: set_asb - procedure, pass(a) :: set_sorted - procedure, pass(a) :: set_upper - procedure, pass(a) :: set_lower - procedure, pass(a) :: set_triangle - procedure, pass(a) :: set_unit ! Getters procedure, pass(a) :: get_nrows procedure, pass(a) :: get_ncols @@ -40,90 +26,574 @@ module psb_c_mat_mod procedure, pass(a) :: is_lower procedure, pass(a) :: is_triangle procedure, pass(a) :: is_unit - procedure, pass(a) :: get_fmt => sparse_get_fmt - procedure, pass(a) :: sizeof => c_sizeof + procedure, pass(a) :: get_fmt => psb_c_get_fmt + procedure, pass(a) :: sizeof => psb_c_sizeof + ! Setters + procedure, pass(a) :: set_nrows => psb_c_set_nrows + procedure, pass(a) :: set_ncols => psb_c_set_ncols + procedure, pass(a) :: set_dupl => psb_c_set_dupl + procedure, pass(a) :: set_state => psb_c_set_state + procedure, pass(a) :: set_null => psb_c_set_null + procedure, pass(a) :: set_bld => psb_c_set_bld + procedure, pass(a) :: set_upd => psb_c_set_upd + procedure, pass(a) :: set_asb => psb_c_set_asb + procedure, pass(a) :: set_sorted => psb_c_set_sorted + procedure, pass(a) :: set_upper => psb_c_set_upper + procedure, pass(a) :: set_lower => psb_c_set_lower + procedure, pass(a) :: set_triangle => psb_c_set_triangle + procedure, pass(a) :: set_unit => psb_c_set_unit ! Memory/data management - procedure, pass(a) :: csall - procedure, pass(a) :: free - procedure, pass(a) :: trim - procedure, pass(a) :: csput - procedure, pass(a) :: c_csgetptn - procedure, pass(a) :: c_csgetrow - procedure, pass(a) :: c_csgetblk + procedure, pass(a) :: csall => psb_c_csall + procedure, pass(a) :: free => psb_c_free + procedure, pass(a) :: trim => psb_c_trim + procedure, pass(a) :: csput => psb_c_csput + procedure, pass(a) :: c_csgetptn => psb_c_csgetptn + procedure, pass(a) :: c_csgetrow => psb_c_csgetrow + procedure, pass(a) :: c_csgetblk => psb_c_csgetblk generic, public :: csget => c_csgetptn, c_csgetrow, c_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: reall => reallocate_nz - procedure, pass(a) :: get_neigh - procedure, pass(a) :: c_cscnv - procedure, pass(a) :: c_cscnv_ip - generic, public :: cscnv => c_cscnv, c_cscnv_ip - procedure, pass(a) :: reinit - procedure, pass(a) :: print => sparse_print - procedure, pass(a) :: c_mv_from + procedure, pass(a) :: c_csclip => psb_c_csclip + procedure, pass(a) :: c_b_csclip => psb_c_b_csclip + generic, public :: csclip => c_b_csclip, c_csclip + procedure, pass(a) :: c_clip_d_ip => psb_c_clip_d_ip + procedure, pass(a) :: c_clip_d => psb_c_clip_d + generic, public :: clip_diag => c_clip_d_ip, c_clip_d + procedure, pass(a) :: reall => psb_c_reallocate_nz + procedure, pass(a) :: get_neigh => psb_c_get_neigh + procedure, pass(a) :: c_cscnv => psb_c_cscnv + procedure, pass(a) :: c_cscnv_ip => psb_c_cscnv_ip + procedure, pass(a) :: c_cscnv_base => psb_c_cscnv_base + generic, public :: cscnv => c_cscnv, c_cscnv_ip, c_cscnv_base + procedure, pass(a) :: reinit => psb_c_reinit + procedure, pass(a) :: print => psb_c_sparse_print + procedure, pass(a) :: c_mv_from => psb_c_mv_from generic, public :: mv_from => c_mv_from - procedure, pass(a) :: c_cp_from + procedure, pass(a) :: c_mv_to => psb_c_mv_to + generic, public :: mv_to => c_mv_to + procedure, pass(a) :: c_cp_from => psb_c_cp_from generic, public :: cp_from => c_cp_from + procedure, pass(a) :: c_cp_to => psb_c_cp_to + generic, public :: cp_to => c_cp_to + procedure, pass(a) :: c_transp_1mat => psb_c_transp_1mat + procedure, pass(a) :: c_transp_2mat => psb_c_transp_2mat + generic, public :: transp => c_transp_1mat, c_transp_2mat + procedure, pass(a) :: c_transc_1mat => psb_c_transc_1mat + procedure, pass(a) :: c_transc_2mat => psb_c_transc_2mat + generic, public :: transc => c_transc_1mat, c_transc_2mat + ! Computational routines - procedure, pass(a) :: get_diag - procedure, pass(a) :: csnmi - procedure, pass(a) :: c_csmv - procedure, pass(a) :: c_csmm + procedure, pass(a) :: get_diag => psb_c_get_diag + procedure, pass(a) :: csnmi => psb_c_csnmi + procedure, pass(a) :: c_csmv => psb_c_csmv + procedure, pass(a) :: c_csmm => psb_c_csmm generic, public :: csmm => c_csmm, c_csmv - procedure, pass(a) :: c_scals - procedure, pass(a) :: c_scal - generic, public :: scal => c_scals, c_scal - procedure, pass(a) :: c_cssv - procedure, pass(a) :: c_cssm + procedure, pass(a) :: c_scals => psb_c_scals + procedure, pass(a) :: c_scal => psb_c_scal + generic, public :: scal => c_scals, c_scal + procedure, pass(a) :: c_cssv => psb_c_cssv + procedure, pass(a) :: c_cssm => psb_c_cssm generic, public :: cssm => c_cssm, c_cssv end type psb_c_sparse_mat private :: get_nrows, get_ncols, get_nzeros, get_size, & & get_state, get_dupl, is_null, is_bld, is_upd, & - & is_asb, is_sorted, is_upper, is_lower, is_triangle, & - & is_unit, get_neigh, csall, csput, c_csgetrow,& - & c_csgetblk, csclip, c_cscnv, c_cscnv_ip, & - & reallocate_nz, free, trim, & - & sparse_print, reinit, & - & set_nrows, set_ncols, set_dupl, & - & set_state, set_null, set_bld, & - & set_upd, set_asb, set_sorted, & - & set_upper, set_lower, set_triangle, & - & set_unit, get_diag, get_nz_row, c_csgetptn, & - & c_mv_from, c_cp_from + & is_asb, is_sorted, is_upper, is_lower, is_triangle interface psb_sizeof - module procedure c_sizeof + module procedure psb_c_sizeof + end interface + + + !===================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !===================================== + + + interface + subroutine psb_c_set_nrows(m,a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + end subroutine psb_c_set_nrows + end interface + + interface + subroutine psb_c_set_ncols(n,a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_c_set_ncols + end interface + + interface + subroutine psb_c_set_state(n,a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_c_set_state + end interface + + interface + subroutine psb_c_set_dupl(n,a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_c_set_dupl + end interface + + interface + subroutine psb_c_set_null(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_set_null + end interface + + interface + subroutine psb_c_set_bld(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_set_bld + end interface + + interface + subroutine psb_c_set_upd(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_set_upd + end interface + + interface + subroutine psb_c_set_asb(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_set_asb + end interface + + interface + subroutine psb_c_set_sorted(a,val) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_sorted + end interface + + interface + subroutine psb_c_set_triangle(a,val) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_triangle + end interface + + interface + subroutine psb_c_set_unit(a,val) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_unit + end interface + + interface + subroutine psb_c_set_lower(a,val) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_lower + end interface + + interface + subroutine psb_c_set_upper(a,val) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_upper + end interface + + + interface + subroutine psb_c_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_c_sparse_mat + integer, intent(in) :: iout + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_c_sparse_print + end interface + + interface + subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_c_get_neigh + end interface + + interface + subroutine psb_c_csall(nr,nc,a,info,nz) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + end subroutine psb_c_csall + end interface + + interface + subroutine psb_c_reallocate_nz(nz,a) + import psb_c_sparse_mat + integer, intent(in) :: nz + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_reallocate_nz + end interface + + interface + subroutine psb_c_free(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_free + end interface + + interface + subroutine psb_c_trim(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_trim + end interface + + interface + subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_c_csput + end interface + + interface + subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csgetptn + end interface + + interface + subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csgetrow end interface + + interface + subroutine psb_c_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csgetblk + end interface + + interface + subroutine psb_c_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csclip + end interface + + interface + subroutine psb_c_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_c_sparse_mat, psb_spk_, psb_c_coo_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_b_csclip + end interface + + interface + subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_c_cscnv + end interface + + interface + subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(out) :: iinfo + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_c_cscnv_ip + end interface + + + interface + subroutine psb_c_cscnv_base(a,b,info,dupl) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + end subroutine psb_c_cscnv_base + end interface + + interface + subroutine psb_c_clip_d(a,b,info) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer,intent(out) :: info + end subroutine psb_c_clip_d + end interface + + interface + subroutine psb_c_clip_d_ip(a,info) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + end subroutine psb_c_clip_d_ip + end interface + + interface + subroutine psb_c_mv_from(a,b) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_mv_from + end interface + + interface + subroutine psb_c_cp_from(a,b) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + end subroutine psb_c_cp_from + end interface + + interface + subroutine psb_c_mv_to(a,b) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + end subroutine psb_c_mv_to + end interface + + interface + subroutine psb_c_cp_to(a,b) + import psb_c_sparse_mat, psb_spk_, psb_c_base_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + end subroutine psb_c_cp_to + end interface + interface psb_move_alloc - module procedure c_sparse_mat_move + subroutine psb_c_sparse_mat_move(a,b,info) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_c_sparse_mat_move end interface + interface psb_clone - module procedure c_sparse_mat_clone + subroutine psb_c_sparse_mat_clone(a,b,info) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_c_sparse_mat_clone + end interface + + interface + subroutine psb_c_transp_1mat(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_transp_1mat end interface + + interface + subroutine psb_c_transp_2mat(a,b) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_sparse_mat), intent(in) :: b + end subroutine psb_c_transp_2mat + end interface + + interface + subroutine psb_c_transc_1mat(a) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + end subroutine psb_c_transc_1mat + end interface + + interface + subroutine psb_c_transc_2mat(a,b) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_sparse_mat), intent(in) :: b + end subroutine psb_c_transc_2mat + end interface + + interface + subroutine psb_c_reinit(a,clear) + import psb_c_sparse_mat + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_c_reinit + + end interface + + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== interface psb_csmm - module procedure c_csmm, c_csmv + subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_csmm + subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_csmv end interface - + interface psb_cssm - module procedure c_cssm, c_cssv + subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_c_cssm + subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_c_cssv end interface - - interface psb_csnmi - module procedure csnmi + + interface + function psb_c_csnmi(a) result(res) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_c_csnmi + end interface + + interface + subroutine psb_c_get_diag(a,d,info) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_get_diag end interface interface psb_scal - module procedure c_scals, c_scal + subroutine psb_c_scal(d,a,info) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_c_scal + subroutine psb_c_scals(d,a,info) + import psb_c_sparse_mat, psb_spk_ + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_c_scals end interface + + + contains @@ -140,7 +610,7 @@ contains !===================================== - function c_sizeof(a) result(res) + function psb_c_sizeof(a) result(res) implicit none class(psb_c_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res @@ -150,11 +620,11 @@ contains res = a%a%sizeof() end if - end function c_sizeof + end function psb_c_sizeof - function sparse_get_fmt(a) result(res) + function psb_c_get_fmt(a) result(res) implicit none class(psb_c_sparse_mat), intent(in) :: a character(len=5) :: res @@ -165,12 +635,11 @@ contains res = 'NULL' end if - end function sparse_get_fmt + end function psb_c_get_fmt function get_dupl(a) result(res) - use psb_error_mod implicit none class(psb_c_sparse_mat), intent(in) :: a integer :: res @@ -341,73 +810,33 @@ contains function get_nzeros(a) result(res) - use psb_error_mod implicit none class(psb_c_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_nzeros() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() end if end function get_nzeros function get_size(a) result(res) - use psb_error_mod + implicit none class(psb_c_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_size' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_size() - - call psb_erractionrestore(err_act) - return -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() end if - return end function get_size function get_nz_row(idx,a) result(res) - use psb_error_mod implicit none integer, intent(in) :: idx class(psb_c_sparse_mat), intent(in) :: a @@ -422,1504 +851,4 @@ contains end function get_nz_row - - !===================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine set_nrows(m,a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - integer, intent(in) :: m - Integer :: err_act, info - character(len=20) :: name='set_nrows' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_nrows(m) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_nrows - - subroutine set_ncols(n,a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_ncols(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_ncols - - - subroutine set_state(n,a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_state(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_state - - - subroutine set_dupl(n,a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_dupl(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_dupl - - subroutine set_null(a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_null() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_null - - subroutine set_bld(a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_bld() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_bld - - subroutine set_upd(a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upd() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_upd - - subroutine set_asb(a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_asb() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_asb - - subroutine set_sorted(a,val) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_sorted(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_sorted - - subroutine set_triangle(a,val) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_triangle(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_triangle - - subroutine set_unit(a,val) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_unit(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_unit - - subroutine set_lower(a,val) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_lower(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_lower - - subroutine set_upper(a,val) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upper(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_upper - - - !===================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !===================================== - - - subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_error_mod - implicit none - - integer, intent(in) :: iout - class(psb_c_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act, info - character(len=20) :: name='sparse_print' - logical, parameter :: debug=.false. - - info = 0 - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine sparse_print - - - - subroutine get_neigh(a,idx,neigh,n,info,lev) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable, intent(out) :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - - Integer :: err_act - character(len=20) :: name='get_neigh' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_neigh(idx,neigh,n,info,lev) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_neigh - - - subroutine csall(nr,nc,a,info,nz) - use psb_c_base_mat_mod - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(out) :: a - integer, intent(in) :: nr,nc - integer, intent(out) :: info - integer, intent(in), optional :: nz - - Integer :: err_act - character(len=20) :: name='csall' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - allocate(psb_c_coo_sparse_mat :: a%a, stat=info) - if (info /= 0) then - info = 4000 - call psb_errpush(info, name) - goto 9999 - end if - call a%a%allocate(nr,nc,nz) - call a%set_bld() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csall - - subroutine reallocate_nz(nz,a) - use psb_error_mod - implicit none - integer, intent(in) :: nz - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='reallocate_nz' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reallocate(nz) - - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine reallocate_nz - - subroutine free(a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='free' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%free() - deallocate(a%a) - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine free - - subroutine trim(a) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%trim() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine trim - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_c_base_mat_mod - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.a%is_bld()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csput - - subroutine c_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod - implicit none - - class(psb_c_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine c_csgetptn - - subroutine c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod - implicit none - - class(psb_c_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine c_csgetrow - - - - subroutine c_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod - implicit none - - class(psb_c_sparse_mat), intent(in) :: a - class(psb_c_sparse_mat), intent(out) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - type(psb_c_coo_sparse_mat), allocatable :: acoo - - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - - if (info == 0) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine c_csgetblk - - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_c_base_mat_mod - implicit none - - class(psb_c_sparse_mat), intent(in) :: a - class(psb_c_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csclip' - logical, parameter :: debug=.false. - type(psb_c_coo_sparse_mat), allocatable :: acoo - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csclip - - - - subroutine c_cscnv(a,b,info,type,mold,upd,dupl) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - class(psb_c_sparse_mat), intent(out) :: b - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_c_base_sparse_mat), intent(in), optional :: mold - - - class(psb_c_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call b%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call b%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_c_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - call b%set_asb() - call b%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine c_cscnv - - - subroutine c_cscnv_ip(a,info,type,mold,dupl) - use psb_error_mod - use psb_string_mod - implicit none - - class(psb_c_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_c_base_sparse_mat), intent(in), optional :: mold - - - class(psb_c_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv_ip' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - 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 = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_c_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%mv_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,a%a) - call a%set_asb() - call a%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine c_cscnv_ip - - subroutine c_mv_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_sparse_mat), intent(out) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer :: info - - allocate(a%a,source=b, stat=info) - call a%a%mv_from_fmt(b,info) - - return - end subroutine c_mv_from - - subroutine c_cp_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_sparse_mat), intent(out) :: a - class(psb_c_base_sparse_mat), intent(inout), allocatable :: b - Integer :: err_act, info - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine c_cp_from - - subroutine c_sparse_mat_move(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - class(psb_c_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='move_alloc' - logical, parameter :: debug=.false. - - info = 0 - call move_alloc(a%a,b%a) - - return - end subroutine c_sparse_mat_move - - subroutine c_sparse_mat_clone(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - class(psb_c_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine c_sparse_mat_clone - - - subroutine reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_c_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - Integer :: err_act, info - character(len=20) :: name='reinit' - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reinit(clear) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine reinit - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine c_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csmm - - subroutine c_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_csmv - - subroutine c_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_cssm - - subroutine c_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_cssv - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%csnmi() - - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end function csnmi - - - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_diag(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_diag - - subroutine c_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_scal - - subroutine c_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_c_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_scals - - end module psb_c_mat_mod diff --git a/base/modules/psb_d_base_mat_mod.f03 b/base/modules/psb_d_base_mat_mod.f03 index f4b6c3ff..1d3c473a 100644 --- a/base/modules/psb_d_base_mat_mod.f03 +++ b/base/modules/psb_d_base_mat_mod.f03 @@ -1,55 +1,52 @@ module psb_d_base_mat_mod use psb_base_mat_mod - + type, extends(psb_base_sparse_mat) :: psb_d_base_sparse_mat contains - procedure, pass(a) :: d_base_csmv - procedure, pass(a) :: d_base_csmm - generic, public :: csmm => d_base_csmm, d_base_csmv - procedure, pass(a) :: d_base_cssv - procedure, pass(a) :: d_base_cssm - generic, public :: base_cssm => d_base_cssm, d_base_cssv - procedure, pass(a) :: d_cssv - procedure, pass(a) :: d_cssm - generic, public :: cssm => d_cssm, d_cssv - procedure, pass(a) :: d_scals - procedure, pass(a) :: d_scal - generic, public :: scal => d_scals, d_scal - procedure, pass(a) :: csnmi - procedure, pass(a) :: get_diag - procedure, pass(a) :: csput - - procedure, pass(a) :: d_csgetrow - procedure, pass(a) :: d_csgetblk - generic, public :: csget => d_csgetrow, d_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: cp_to_coo - procedure, pass(a) :: cp_from_coo - procedure, pass(a) :: cp_to_fmt - procedure, pass(a) :: cp_from_fmt - procedure, pass(a) :: mv_to_coo - procedure, pass(a) :: mv_from_coo - procedure, pass(a) :: mv_to_fmt - procedure, pass(a) :: mv_from_fmt + procedure, pass(a) :: d_csmv => psb_d_base_csmv + procedure, pass(a) :: d_csmm => psb_d_base_csmm + generic, public :: csmm => d_csmm, d_csmv + procedure, pass(a) :: d_inner_cssv => psb_d_base_inner_cssv + procedure, pass(a) :: d_inner_cssm => psb_d_base_inner_cssm + generic, public :: inner_cssm => d_inner_cssm, d_inner_cssv + procedure, pass(a) :: d_cssv => psb_d_base_cssv + procedure, pass(a) :: d_cssm => psb_d_base_cssm + generic, public :: cssm => d_cssm, d_cssv + procedure, pass(a) :: d_scals => psb_d_base_scals + procedure, pass(a) :: d_scal => psb_d_base_scal + generic, public :: scal => d_scals, d_scal + procedure, pass(a) :: csnmi => psb_d_base_csnmi + procedure, pass(a) :: get_diag => psb_d_base_get_diag + + procedure, pass(a) :: csput => psb_d_base_csput + procedure, pass(a) :: d_csgetrow => psb_d_base_csgetrow + procedure, pass(a) :: d_csgetblk => psb_d_base_csgetblk + generic, public :: csget => d_csgetrow, d_csgetblk + procedure, pass(a) :: csclip => psb_d_base_csclip + procedure, pass(a) :: cp_to_coo => psb_d_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_d_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_d_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_d_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_d_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_d_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_d_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_d_base_mv_from_fmt procedure, pass(a) :: d_base_cp_from generic, public :: cp_from => d_base_cp_from procedure, pass(a) :: d_base_mv_from generic, public :: mv_from => d_base_mv_from - - procedure, pass(a) :: base_transp_1mat => d_base_transp_1mat - procedure, pass(a) :: base_transp_2mat => d_base_transp_2mat - procedure, pass(a) :: base_transc_1mat => d_base_transc_1mat - procedure, pass(a) :: base_transc_2mat => d_base_transc_2mat - + + procedure, pass(a) :: transp_1mat => psb_d_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_d_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_d_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_d_base_transc_2mat + end type psb_d_base_sparse_mat - - private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,& - & d_scals, d_scal, csnmi, csput, d_csgetrow, d_csgetblk, & - & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & - & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & - & get_diag, csclip, d_cssv, d_cssm, base_cp_from, base_mv_from - + + private :: d_base_cssv, d_base_cssm, d_base_cp_from, d_base_mv_from + + type, extends(psb_d_base_sparse_mat) :: psb_d_coo_sparse_mat integer :: nnz @@ -58,180 +55,511 @@ module psb_d_base_mat_mod contains - procedure, pass(a) :: get_size => d_coo_get_size - procedure, pass(a) :: get_nzeros => d_coo_get_nzeros - procedure, pass(a) :: set_nzeros => d_coo_set_nzeros - procedure, pass(a) :: d_base_csmm => d_coo_csmm - procedure, pass(a) :: d_base_csmv => d_coo_csmv - procedure, pass(a) :: d_base_cssm => d_coo_cssm - procedure, pass(a) :: d_base_cssv => d_coo_cssv - procedure, pass(a) :: d_scals => d_coo_scals - procedure, pass(a) :: d_scal => d_coo_scal - procedure, pass(a) :: csnmi => d_coo_csnmi - procedure, pass(a) :: csput => d_coo_csput - procedure, pass(a) :: get_diag => d_coo_get_diag - procedure, pass(a) :: reallocate_nz => d_coo_reallocate_nz - procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz - procedure, pass(a) :: cp_to_coo => d_cp_coo_to_coo - procedure, pass(a) :: cp_from_coo => d_cp_coo_from_coo - procedure, pass(a) :: cp_to_fmt => d_cp_coo_to_fmt - procedure, pass(a) :: cp_from_fmt => d_cp_coo_from_fmt - procedure, pass(a) :: mv_to_coo => d_mv_coo_to_coo - procedure, pass(a) :: mv_from_coo => d_mv_coo_from_coo - procedure, pass(a) :: mv_to_fmt => d_mv_coo_to_fmt - procedure, pass(a) :: mv_from_fmt => d_mv_coo_from_fmt - procedure, pass(a) :: fix => d_fix_coo - procedure, pass(a) :: free => d_coo_free - procedure, pass(a) :: trim => d_coo_trim - procedure, pass(a) :: d_csgetrow => d_coo_csgetrow - procedure, pass(a) :: csgetptn => d_coo_csgetptn - procedure, pass(a) :: print => d_coo_print - procedure, pass(a) :: get_fmt => d_coo_get_fmt - procedure, pass(a) :: get_nz_row => d_coo_get_nz_row - procedure, pass(a) :: sizeof => d_coo_sizeof - procedure, pass(a) :: reinit => d_coo_reinit - procedure, pass(a) :: d_coo_cp_from - generic, public :: cp_from => d_coo_cp_from - procedure, pass(a) :: d_coo_mv_from - generic, public :: mv_from => d_coo_mv_from - procedure, pass(a) :: base_transp_1mat => d_coo_transp_1mat - procedure, pass(a) :: base_transc_1mat => d_coo_transc_1mat + procedure, pass(a) :: get_size => d_coo_get_size + procedure, pass(a) :: get_nzeros => d_coo_get_nzeros + procedure, pass(a) :: set_nzeros => d_coo_set_nzeros + procedure, pass(a) :: get_fmt => d_coo_get_fmt + procedure, pass(a) :: sizeof => d_coo_sizeof + procedure, pass(a) :: d_csmm => psb_d_coo_csmm + procedure, pass(a) :: d_csmv => psb_d_coo_csmv + procedure, pass(a) :: d_inner_cssm => psb_d_coo_cssm + procedure, pass(a) :: d_inner_cssv => psb_d_coo_cssv + procedure, pass(a) :: d_scals => psb_d_coo_scals + procedure, pass(a) :: d_scal => psb_d_coo_scal + procedure, pass(a) :: csnmi => psb_d_coo_csnmi + procedure, pass(a) :: reallocate_nz => psb_d_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_d_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_d_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_d_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_d_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_d_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_d_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_d_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_d_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_d_mv_coo_from_fmt + procedure, pass(a) :: csput => psb_d_coo_csput + procedure, pass(a) :: get_diag => psb_d_coo_get_diag + procedure, pass(a) :: d_csgetrow => psb_d_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_d_coo_csgetptn + procedure, pass(a) :: get_nz_row => psb_d_coo_get_nz_row + procedure, pass(a) :: reinit => psb_d_coo_reinit + procedure, pass(a) :: fix => psb_d_fix_coo + procedure, pass(a) :: trim => psb_d_coo_trim + procedure, pass(a) :: print => psb_d_coo_print + procedure, pass(a) :: free => d_coo_free + procedure, pass(a) :: psb_d_coo_cp_from + generic, public :: cp_from => psb_d_coo_cp_from + procedure, pass(a) :: psb_d_coo_mv_from + generic, public :: mv_from => psb_d_coo_mv_from + procedure, pass(a) :: transp_1mat => d_coo_transp_1mat + procedure, pass(a) :: transc_1mat => d_coo_transc_1mat end type psb_d_coo_sparse_mat - - private :: d_coo_get_nzeros, d_coo_set_nzeros, d_coo_get_diag, & - & d_coo_csmm, d_coo_csmv, d_coo_cssm, d_coo_cssv, d_coo_csnmi, & - & d_coo_csput, d_coo_reallocate_nz, d_coo_allocate_mnnz, & - & d_fix_coo, d_coo_free, d_coo_print, d_coo_get_fmt, & - & d_cp_coo_to_coo, d_cp_coo_from_coo, & - & d_cp_coo_to_fmt, d_cp_coo_from_fmt, & - & d_coo_scals, d_coo_scal, d_coo_csgetrow, d_coo_sizeof, & - & d_coo_csgetptn, d_coo_get_nz_row, d_coo_reinit,& - & d_coo_cp_from, d_coo_mv_from, & + + private :: d_coo_get_nzeros, d_coo_set_nzeros, & + & d_coo_get_fmt, d_coo_free, d_coo_sizeof, & & d_coo_transp_1mat, d_coo_transc_1mat - + + + + !=================== + ! + ! BASE interfaces + ! + !=================== + + + interface + subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_base_csmm + end interface + + interface + subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_base_csmv + end interface + + interface + subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_base_inner_cssm + end interface + + interface + subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_base_inner_cssv + end interface + + interface + subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_d_base_cssm + end interface + + interface + subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_d_base_cssv + end interface + + interface + subroutine psb_d_base_scals(d,a,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_d_base_scals + end interface + + interface + subroutine psb_d_base_scal(d,a,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_base_scal + end interface + + interface + function psb_d_base_csnmi(a) result(res) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_base_csnmi + end interface + + interface + subroutine psb_d_base_get_diag(a,d,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_base_get_diag + end interface + + interface + subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_d_base_csput + end interface + + interface + subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_base_csgetrow + end interface + + interface + subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_base_csgetblk + end interface + + + interface + subroutine psb_d_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_base_csclip + end interface + + + interface + subroutine psb_d_base_cp_to_coo(a,b,info) + import psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_base_cp_to_coo + end interface + + interface + subroutine psb_d_base_cp_from_coo(a,b,info) + import psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_d_base_cp_from_coo + end interface + + interface + subroutine psb_d_base_cp_to_fmt(a,b,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_base_cp_to_fmt + end interface + + interface + subroutine psb_d_base_cp_from_fmt(a,b,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_d_base_cp_from_fmt + end interface + + interface + subroutine psb_d_base_mv_to_coo(a,b,info) + import psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_base_mv_to_coo + end interface + + interface + subroutine psb_d_base_mv_from_coo(a,b,info) + import psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_base_mv_from_coo + end interface + + interface + subroutine psb_d_base_mv_to_fmt(a,b,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_base_mv_to_fmt + end interface + + interface + subroutine psb_d_base_mv_from_fmt(a,b,info) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_base_mv_from_fmt + end interface + + interface + subroutine psb_d_base_transp_2mat(a,b) + import psb_d_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_d_base_transp_2mat + end interface + + interface + subroutine psb_d_base_transc_2mat(a,b) + import psb_d_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_d_base_transc_2mat + end interface + + interface + subroutine psb_d_base_transp_1mat(a) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + end subroutine psb_d_base_transp_1mat + end interface + + interface + subroutine psb_d_base_transc_1mat(a) + import psb_d_base_sparse_mat, psb_dpk_ + class(psb_d_base_sparse_mat), intent(inout) :: a + end subroutine psb_d_base_transc_1mat + end interface + + + + + !================= + ! + ! COO interfaces + ! + !================= + + interface + subroutine psb_d_coo_reallocate_nz(nz,a) + import psb_d_coo_sparse_mat + integer, intent(in) :: nz + class(psb_d_coo_sparse_mat), intent(inout) :: a + end subroutine psb_d_coo_reallocate_nz + end interface + + interface + subroutine psb_d_coo_reinit(a,clear) + import psb_d_coo_sparse_mat + class(psb_d_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_d_coo_reinit + end interface + + interface + subroutine psb_d_coo_trim(a) + import psb_d_coo_sparse_mat + class(psb_d_coo_sparse_mat), intent(inout) :: a + end subroutine psb_d_coo_trim + end interface + + interface + subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) + import psb_d_coo_sparse_mat + integer, intent(in) :: m,n + class(psb_d_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_d_coo_allocate_mnnz + end interface + + interface + subroutine psb_d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_d_coo_sparse_mat + integer, intent(in) :: iout + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_coo_print + end interface + + + interface + function psb_d_coo_get_nz_row(idx,a) result(res) + import psb_d_coo_sparse_mat + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + end function psb_d_coo_get_nz_row + end interface + interface - subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod + subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + import psb_dpk_ integer, intent(in) :: nzin,dupl integer, intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) integer, intent(out) :: nzout, info integer, intent(in), optional :: idir - end subroutine d_fix_coo_inner + end subroutine psb_d_fix_coo_inner end interface - + interface - subroutine d_fix_coo_impl(a,info,idir) - use psb_const_mod + subroutine psb_d_fix_coo(a,info,idir) import psb_d_coo_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a integer, intent(out) :: info integer, intent(in), optional :: idir - end subroutine d_fix_coo_impl + end subroutine psb_d_fix_coo end interface - + interface - subroutine d_cp_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_d_cp_coo_to_coo(a,b,info) import psb_d_coo_sparse_mat class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_cp_coo_to_coo_impl + end subroutine psb_d_cp_coo_to_coo end interface interface - subroutine d_cp_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_d_cp_coo_from_coo(a,b,info) import psb_d_coo_sparse_mat - class(psb_d_coo_sparse_mat), intent(out) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine d_cp_coo_from_coo_impl + end subroutine psb_d_cp_coo_from_coo end interface - + interface - subroutine d_cp_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_d_cp_coo_to_fmt(a,b,info) import psb_d_coo_sparse_mat, psb_d_base_sparse_mat class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_cp_coo_to_fmt_impl + end subroutine psb_d_cp_coo_to_fmt end interface - + interface - subroutine d_cp_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_d_cp_coo_from_fmt(a,b,info) import psb_d_coo_sparse_mat, psb_d_base_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine d_cp_coo_from_fmt_impl + end subroutine psb_d_cp_coo_from_fmt end interface - + interface - subroutine d_mv_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_d_mv_coo_to_coo(a,b,info) import psb_d_coo_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_coo_to_coo_impl + end subroutine psb_d_mv_coo_to_coo end interface - + interface - subroutine d_mv_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_d_mv_coo_from_coo(a,b,info) import psb_d_coo_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_coo_from_coo_impl + end subroutine psb_d_mv_coo_from_coo end interface - + interface - subroutine d_mv_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_d_mv_coo_to_fmt(a,b,info) import psb_d_coo_sparse_mat, psb_d_base_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_coo_to_fmt_impl + end subroutine psb_d_mv_coo_to_fmt end interface - + interface - subroutine d_mv_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_d_mv_coo_from_fmt(a,b,info) import psb_d_coo_sparse_mat, psb_d_base_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_coo_from_fmt_impl + end subroutine psb_d_mv_coo_from_fmt end interface - - + interface - subroutine d_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_d_coo_sparse_mat + subroutine psb_d_coo_cp_from(a,b) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(inout) :: a + type(psb_d_coo_sparse_mat), intent(in) :: b + end subroutine psb_d_coo_cp_from + end interface + + interface + subroutine psb_d_coo_mv_from(a,b) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(inout) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: b + end subroutine psb_d_coo_mv_from + end interface + + + interface + subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer, intent(in) :: nz,ia(:), ja(:),& & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_coo_csput_impl + end subroutine psb_d_coo_csput end interface - + interface - subroutine d_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_d_coo_sparse_mat - implicit none + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -241,16 +569,13 @@ module psb_d_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_coo_csgetptn_impl + end subroutine psb_d_coo_csgetptn end interface interface - subroutine d_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_d_coo_sparse_mat - implicit none - + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -261,1176 +586,117 @@ module psb_d_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_coo_csgetrow_impl + end subroutine psb_d_coo_csgetrow end interface - interface d_coo_cssm_impl - subroutine d_coo_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_coo_sparse_mat + interface + subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_coo_cssv_impl - subroutine d_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_coo_sparse_mat + end subroutine psb_d_coo_cssv + subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_coo_cssm_impl + end subroutine psb_d_coo_cssm end interface - - interface d_coo_csmm_impl - subroutine d_coo_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_coo_sparse_mat + + interface + subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_coo_csmv_impl - subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_coo_sparse_mat + end subroutine psb_d_coo_csmv + subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_coo_csmm_impl + end subroutine psb_d_coo_csmm end interface - - - interface d_coo_csnmi_impl - function d_coo_csnmi_impl(a) result(res) - use psb_const_mod - import psb_d_coo_sparse_mat + + + interface + function psb_d_coo_csnmi(a) result(res) + import psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function d_coo_csnmi_impl + end function psb_d_coo_csnmi end interface - - + + interface + subroutine psb_d_coo_get_diag(a,d,info) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_coo_get_diag + end interface + + interface + subroutine psb_d_coo_scal(d,a,info) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_coo_scal + end interface + + interface + subroutine psb_d_coo_scals(d,a,info) + import psb_d_coo_sparse_mat, psb_dpk_ + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_d_coo_scals + end interface + + contains - - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - subroutine cp_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_coo - - subroutine cp_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_coo - - - subroutine cp_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_fmt - - subroutine cp_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_fmt - - - subroutine mv_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_coo - - subroutine mv_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_coo - - - subroutine mv_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_fmt - - subroutine mv_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_fmt - + + subroutine d_base_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_base_sparse_mat), intent(out) :: a - type(psb_d_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine d_base_mv_from - - subroutine d_base_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_base_sparse_mat), intent(out) :: a - type(psb_d_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine d_base_cp_from - - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine csput - - subroutine d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_base_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_csgetrow - - - - subroutine d_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csgetblk - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csclip - - - - ! - ! Here we go. - ! - subroutine d_coo_transp_1mat(a) - use psb_error_mod - implicit none - - class(psb_d_coo_sparse_mat), intent(inout) :: a - - integer, allocatable :: itemp(:) - integer :: info - - call a%psb_d_base_sparse_mat%psb_base_sparse_mat%transp() - call move_alloc(a%ia,itemp) - call move_alloc(a%ja,a%ia) - call move_alloc(itemp,a%ja) - - call a%fix(info) - - return - - end subroutine d_coo_transp_1mat - - subroutine d_coo_transc_1mat(a) - use psb_error_mod implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(out) :: a + type(psb_d_base_sparse_mat), intent(inout) :: b - call a%transp() - end subroutine d_coo_transc_1mat - - subroutine d_base_transp_2mat(a,b) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - type(psb_d_coo_sparse_mat) :: tmp - integer err_act, info - character(len=*), parameter :: name='d_base_transp' + ! No new things here, very easy + call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - call psb_erractionsave(err_act) - - info = 0 - select type(b) - class is (psb_d_base_sparse_mat) - call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - class default - info = 700 - end select - if (info /= 0) then - call psb_errpush(info,name,a_err=b%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - end subroutine d_base_transp_2mat - - subroutine d_base_transc_2mat(a,b) - use psb_error_mod + end subroutine d_base_mv_from + + subroutine d_base_cp_from(a,b) implicit none class(psb_d_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - call a%transp(b) - end subroutine d_base_transc_2mat - - subroutine d_base_transp_1mat(a) - use psb_error_mod - implicit none - - class(psb_d_base_sparse_mat), intent(inout) :: a - - type(psb_d_coo_sparse_mat) :: tmp - integer :: err_act, info - character(len=*), parameter :: name='d_base_transp' - - call psb_erractionsave(err_act) - info = 0 - call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - - if (info /= 0) then - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - - - end subroutine d_base_transp_1mat - - subroutine d_base_transc_1mat(a) - use psb_error_mod - implicit none - - class(psb_d_base_sparse_mat), intent(inout) :: a - - call a%transp() - end subroutine d_base_transc_1mat - - - - - !==================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !==================================== - - subroutine d_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='d_base_csmm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_base_csmm - - subroutine d_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='d_base_csmv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine d_base_csmv - - subroutine d_base_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='d_base_cssm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_base_cssm - - subroutine d_base_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='d_base_cssv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_base_cssv - - subroutine d_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - - real(psb_dpk_), allocatable :: tmp(:,:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='d_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(done,x,dzero,tmp,info,trans) - - if (info == 0)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == 0)& - & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine d_cssm - - subroutine d_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - - real(psb_dpk_), allocatable :: tmp(:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='d_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) call inner_vscal(nac,d,x,tmp) - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - if (beta == dzero) then - call a%base_cssm(alpha,x,dzero,y,info,trans) - if (info == 0) call inner_vscal1(nar,d,y) - else - allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(alpha,x,dzero,tmp,info,trans) - - if (info == 0) call inner_vscal1(nar,d,tmp) - if (info == 0)& - & call psb_geaxpby(nar,done,tmp,beta,y,info) - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - contains - subroutine inner_vscal(n,d,x,y) - implicit none - integer, intent(in) :: n - real(psb_dpk_), intent(in) :: d(*),x(*) - real(psb_dpk_), intent(out) :: y(*) - integer :: i - - do i=1,n - y(i) = d(i)*x(i) - end do - end subroutine inner_vscal - - subroutine inner_vscal1(n,d,x) - implicit none - integer, intent(in) :: n - real(psb_dpk_), intent(in) :: d(*) - real(psb_dpk_), intent(inout) :: x(*) - integer :: i - - do i=1,n - x(i) = d(i)*x(i) - end do - end subroutine inner_vscal1 - - end subroutine d_cssv - - - subroutine d_scals(d,a,info) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='d_scals' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_scals - - - subroutine d_scal(d,a,info) - use psb_error_mod - implicit none - class(psb_d_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='d_scal' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + type(psb_d_base_sparse_mat), intent(in) :: b + + ! No new things here, very easy + call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - end subroutine d_scal - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = -done - - return - - end function csnmi - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine get_diag - - - - + + end subroutine d_base_cp_from + + + !==================================== ! ! @@ -1442,8 +708,8 @@ contains ! ! !==================================== - - + + function d_coo_sizeof(a) result(res) implicit none @@ -1453,24 +719,24 @@ contains res = res + psb_sizeof_dp * size(a%val) res = res + psb_sizeof_int * size(a%ia) res = res + psb_sizeof_int * size(a%ja) - + end function d_coo_sizeof - - + + function d_coo_get_fmt(a) result(res) implicit none class(psb_d_coo_sparse_mat), intent(in) :: a character(len=5) :: res res = 'COO' end function d_coo_get_fmt - - + + function d_coo_get_size(a) result(res) implicit none class(psb_d_coo_sparse_mat), intent(in) :: a integer :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) if (allocated(a%ja)) then if (res >= 0) then @@ -1487,66 +753,16 @@ contains end if end if end function d_coo_get_size - - + + function d_coo_get_nzeros(a) result(res) implicit none class(psb_d_coo_sparse_mat), intent(in) :: a integer :: res res = a%nnz end function d_coo_get_nzeros - - - function d_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - implicit none - - class(psb_d_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer :: res - integer :: nzin_, nza,ip,jp,i,k - - res = 0 - nza = a%get_nzeros() - if (a%is_sorted()) then - ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - - end function d_coo_get_nz_row - + + !==================================== ! ! @@ -1559,807 +775,49 @@ contains ! ! !==================================== - - subroutine d_coo_set_nzeros(nz,a) - implicit none - integer, intent(in) :: nz - class(psb_d_coo_sparse_mat), intent(inout) :: a - - a%nnz = nz - - end subroutine d_coo_set_nzeros - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - - subroutine d_fix_coo(a,info,idir) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: idir - Integer :: err_act - character(len=20) :: name='fix_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_fix_coo_impl(a,info,idir) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine d_fix_coo - - - subroutine d_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_coo_to_coo - - subroutine d_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(out) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_coo_from_coo - - - subroutine d_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_coo_to_fmt - - subroutine d_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_coo_from_fmt - - - - subroutine d_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_coo_to_coo - - subroutine d_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_coo_from_coo - - - - subroutine d_coo_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_coo_sparse_mat), intent(out) :: a - type(psb_d_coo_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_coo_cp_from - - subroutine d_coo_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_coo_sparse_mat), intent(out) :: a - type(psb_d_coo_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_coo_mv_from - - - subroutine d_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_coo_to_fmt - - subroutine d_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_coo_from_fmt - - - - subroutine d_coo_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_d_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='d_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,a%ja,a%val,info) - - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_reallocate_nz - - - subroutine d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='d_coo_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - nza = a%get_nzeros() - call d_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_csput - - - subroutine d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + + subroutine d_coo_set_nzeros(nz,a) + implicit none + integer, intent(in) :: nz + class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call d_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_csgetrow - - - subroutine d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + a%nnz = nz - class(psb_d_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call d_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_csgetptn - - + end subroutine d_coo_set_nzeros + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + + subroutine d_coo_free(a) implicit none - + class(psb_d_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() call a%set_nrows(0) call a%set_ncols(0) - + call a%set_nzeros(0) + return - + end subroutine d_coo_free - - subroutine d_coo_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_d_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = dzero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_reinit - - - subroutine d_coo_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_trim - - subroutine d_coo_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_d_coo_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(0) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - end if - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_allocate_mnnz - - - subroutine d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_d_coo_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='d_coo_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - - end subroutine d_coo_print - - - - + + + !==================================== ! ! @@ -2372,381 +830,33 @@ contains ! ! !==================================== - - subroutine d_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod + subroutine d_coo_transp_1mat(a) implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nac, nar - real(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='d_coo_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - call d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_csmv - - subroutine d_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - real(psb_dpk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + class(psb_d_coo_sparse_mat), intent(inout) :: a - call d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_csmm - - - subroutine d_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nar, nac - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_coo_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + integer, allocatable :: itemp(:) + integer :: info - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call d_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine d_coo_cssv - - - - subroutine d_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + call a%psb_d_base_sparse_mat%psb_base_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%fix(info) - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call d_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_cssm - - function d_coo_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = d_coo_csnmi_impl(a) - - return - - end function d_coo_csnmi - - subroutine d_coo_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = dzero - - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_coo_get_diag - - subroutine d_coo_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine d_coo_scal - - subroutine d_coo_scals(d,a,info) - use psb_error_mod - use psb_const_mod + + end subroutine d_coo_transp_1mat + + subroutine d_coo_transc_1mat(a) implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + + call a%transp() + end subroutine d_coo_transc_1mat - end subroutine d_coo_scals end module psb_d_base_mat_mod diff --git a/base/modules/psb_d_csc_mat_mod.f03 b/base/modules/psb_d_csc_mat_mod.f03 index 387c3417..7df12cae 100644 --- a/base/modules/psb_d_csc_mat_mod.f03 +++ b/base/modules/psb_d_csc_mat_mod.f03 @@ -8,161 +8,195 @@ module psb_d_csc_mat_mod real(psb_dpk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => d_csc_get_nzeros - procedure, pass(a) :: get_fmt => d_csc_get_fmt - procedure, pass(a) :: get_diag => d_csc_get_diag - procedure, pass(a) :: d_base_csmm => d_csc_csmm - procedure, pass(a) :: d_base_csmv => d_csc_csmv - procedure, pass(a) :: d_base_cssm => d_csc_cssm - procedure, pass(a) :: d_base_cssv => d_csc_cssv - procedure, pass(a) :: d_scals => d_csc_scals - procedure, pass(a) :: d_scal => d_csc_scal - procedure, pass(a) :: csnmi => d_csc_csnmi - procedure, pass(a) :: reallocate_nz => d_csc_reallocate_nz - procedure, pass(a) :: csput => d_csc_csput - procedure, pass(a) :: allocate_mnnz => d_csc_allocate_mnnz - procedure, pass(a) :: cp_to_coo => d_cp_csc_to_coo - procedure, pass(a) :: cp_from_coo => d_cp_csc_from_coo - procedure, pass(a) :: cp_to_fmt => d_cp_csc_to_fmt - procedure, pass(a) :: cp_from_fmt => d_cp_csc_from_fmt - procedure, pass(a) :: mv_to_coo => d_mv_csc_to_coo - procedure, pass(a) :: mv_from_coo => d_mv_csc_from_coo - procedure, pass(a) :: mv_to_fmt => d_mv_csc_to_fmt - procedure, pass(a) :: mv_from_fmt => d_mv_csc_from_fmt - procedure, pass(a) :: csgetptn => d_csc_csgetptn - procedure, pass(a) :: d_csgetrow => d_csc_csgetrow - procedure, pass(a) :: get_size => d_csc_get_size - procedure, pass(a) :: free => d_csc_free - procedure, pass(a) :: trim => d_csc_trim - procedure, pass(a) :: print => d_csc_print - procedure, pass(a) :: sizeof => d_csc_sizeof - procedure, pass(a) :: reinit => d_csc_reinit - procedure, pass(a) :: d_csc_cp_from - generic, public :: cp_from => d_csc_cp_from - procedure, pass(a) :: d_csc_mv_from - generic, public :: mv_from => d_csc_mv_from - end type psb_d_csc_sparse_mat + procedure, pass(a) :: get_size => d_csc_get_size + procedure, pass(a) :: get_nzeros => d_csc_get_nzeros + procedure, pass(a) :: get_fmt => d_csc_get_fmt + procedure, pass(a) :: sizeof => d_csc_sizeof + procedure, pass(a) :: d_csmm => psb_d_csc_csmm + procedure, pass(a) :: d_csmv => psb_d_csc_csmv + procedure, pass(a) :: d_inner_cssm => psb_d_csc_cssm + procedure, pass(a) :: d_inner_cssv => psb_d_csc_cssv + procedure, pass(a) :: d_scals => psb_d_csc_scals + procedure, pass(a) :: d_scal => psb_d_csc_scal + procedure, pass(a) :: csnmi => psb_d_csc_csnmi + procedure, pass(a) :: reallocate_nz => psb_d_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_d_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_d_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_d_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_d_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_d_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_d_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_d_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_d_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_d_mv_csc_from_fmt + procedure, pass(a) :: csput => psb_d_csc_csput + procedure, pass(a) :: get_diag => psb_d_csc_get_diag + procedure, pass(a) :: csgetptn => psb_d_csc_csgetptn + procedure, pass(a) :: d_csgetrow => psb_d_csc_csgetrow + procedure, pass(a) :: get_nz_col => d_csc_get_nz_col + procedure, pass(a) :: reinit => psb_d_csc_reinit + procedure, pass(a) :: trim => psb_d_csc_trim + procedure, pass(a) :: print => psb_d_csc_print + procedure, pass(a) :: free => d_csc_free + procedure, pass(a) :: psb_d_csc_cp_from + generic, public :: cp_from => psb_d_csc_cp_from + procedure, pass(a) :: psb_d_csc_mv_from + generic, public :: mv_from => psb_d_csc_mv_from - private :: d_csc_get_nzeros, d_csc_csmm, d_csc_csmv, d_csc_cssm, d_csc_cssv, & - & d_csc_csput, d_csc_reallocate_nz, d_csc_allocate_mnnz, & - & d_csc_free, d_csc_print, d_csc_get_fmt, d_csc_csnmi, get_diag, & - & d_cp_csc_to_coo, d_cp_csc_from_coo, & - & d_mv_csc_to_coo, d_mv_csc_from_coo, & - & d_cp_csc_to_fmt, d_cp_csc_from_fmt, & - & d_mv_csc_to_fmt, d_mv_csc_from_fmt, & - & d_csc_scals, d_csc_scal, d_csc_trim, d_csc_csgetrow, d_csc_get_size, & - & d_csc_sizeof, d_csc_csgetptn, d_csc_get_nz_row, d_csc_reinit + end type psb_d_csc_sparse_mat + private :: d_csc_get_nzeros, d_csc_free, d_csc_get_fmt, & + & d_csc_get_size, d_csc_sizeof, d_csc_get_nz_col - interface - subroutine d_cp_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + interface + subroutine psb_d_csc_reallocate_nz(nz,a) import psb_d_csc_sparse_mat - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine d_cp_csc_to_fmt_impl + integer, intent(in) :: nz + class(psb_d_csc_sparse_mat), intent(inout) :: a + end subroutine psb_d_csc_reallocate_nz end interface - + interface - subroutine d_cp_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + subroutine psb_d_csc_reinit(a,clear) + import psb_d_csc_sparse_mat + class(psb_d_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_d_csc_reinit + end interface + + interface + subroutine psb_d_csc_trim(a) import psb_d_csc_sparse_mat class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine d_cp_csc_from_fmt_impl + end subroutine psb_d_csc_trim end interface - - - interface - subroutine d_cp_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + + interface + subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) import psb_d_csc_sparse_mat + integer, intent(in) :: m,n + class(psb_d_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_d_csc_allocate_mnnz + end interface + + interface + subroutine psb_d_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_d_csc_sparse_mat + integer, intent(in) :: iout + class(psb_d_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_csc_print + end interface + + interface + subroutine psb_d_cp_csc_to_coo(a,b,info) + import psb_d_coo_sparse_mat, psb_d_csc_sparse_mat class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_cp_csc_to_coo_impl + end subroutine psb_d_cp_csc_to_coo end interface - + interface - subroutine d_cp_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csc_sparse_mat + subroutine psb_d_cp_csc_from_coo(a,b,info) + import psb_d_csc_sparse_mat, psb_d_coo_sparse_mat class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine d_cp_csc_from_coo_impl + end subroutine psb_d_cp_csc_from_coo end interface - + interface - subroutine d_mv_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csc_sparse_mat + subroutine psb_d_cp_csc_to_fmt(a,b,info) + import psb_d_csc_sparse_mat, psb_d_base_sparse_mat + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_cp_csc_to_fmt + end interface + + interface + subroutine psb_d_cp_csc_from_fmt(a,b,info) + import psb_d_csc_sparse_mat, psb_d_base_sparse_mat + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_d_cp_csc_from_fmt + end interface + + interface + subroutine psb_d_mv_csc_to_coo(a,b,info) + import psb_d_csc_sparse_mat, psb_d_coo_sparse_mat class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_csc_to_fmt_impl + end subroutine psb_d_mv_csc_to_coo end interface - + interface - subroutine d_mv_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csc_sparse_mat + subroutine psb_d_mv_csc_from_coo(a,b,info) + import psb_d_csc_sparse_mat, psb_d_coo_sparse_mat + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_mv_csc_from_coo + end interface + + interface + subroutine psb_d_mv_csc_to_fmt(a,b,info) + import psb_d_csc_sparse_mat, psb_d_base_sparse_mat + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_mv_csc_to_fmt + end interface + + interface + subroutine psb_d_mv_csc_from_fmt(a,b,info) + import psb_d_csc_sparse_mat, psb_d_base_sparse_mat class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_csc_from_fmt_impl + end subroutine psb_d_mv_csc_from_fmt end interface - - + interface - subroutine d_mv_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csc_sparse_mat + subroutine psb_d_csc_cp_from(a,b) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine d_mv_csc_to_coo_impl + type(psb_d_csc_sparse_mat), intent(in) :: b + end subroutine psb_d_csc_cp_from end interface - + interface - subroutine d_mv_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csc_sparse_mat - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine d_mv_csc_from_coo_impl + subroutine psb_d_csc_mv_from(a,b) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(inout) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: b + end subroutine psb_d_csc_mv_from end interface - + + interface - subroutine d_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_d_csc_sparse_mat + subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_csc_csput_impl + end subroutine psb_d_csc_csput end interface - + interface - subroutine d_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_d_csc_sparse_mat - implicit none - + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -172,16 +206,13 @@ module psb_d_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_csc_csgetptn_impl + end subroutine psb_d_csc_csgetptn end interface - + interface - subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_d_csc_sparse_mat - implicit none - + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -192,61 +223,98 @@ module psb_d_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_csc_csgetrow_impl + end subroutine psb_d_csc_csgetrow end interface - interface d_csc_cssm_impl - subroutine d_csc_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csc_sparse_mat + interface + subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_d_csc_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csc_csgetblk + end interface + + interface + subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csc_cssv_impl - subroutine d_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csc_sparse_mat + end subroutine psb_d_csc_cssv + subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csc_cssm_impl + end subroutine psb_d_csc_cssm end interface - - interface d_csc_csmm_impl - subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csc_sparse_mat + + interface + subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csc_csmv_impl - subroutine d_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csc_sparse_mat + end subroutine psb_d_csc_csmv + subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csc_csmm_impl + end subroutine psb_d_csc_csmm end interface - - interface d_csc_csnmi_impl - function d_csc_csnmi_impl(a) result(res) - use psb_const_mod - import psb_d_csc_sparse_mat + + + interface + function psb_d_csc_csnmi(a) result(res) + import psb_d_csc_sparse_mat, psb_dpk_ class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function d_csc_csnmi_impl + end function psb_d_csc_csnmi + end interface + + interface + subroutine psb_d_csc_get_diag(a,d,info) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_csc_get_diag + end interface + + interface + subroutine psb_d_csc_scal(d,a,info) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_csc_scal + end interface + + interface + subroutine psb_d_csc_scals(d,a,info) + import psb_d_csc_sparse_mat, psb_dpk_ + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_d_csc_scals end interface - contains @@ -345,339 +413,6 @@ contains !===================================== - subroutine d_csc_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_d_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='d_csc_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_reallocate_nz - - subroutine d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='d_csc_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call d_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_csc_csput - - subroutine d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call d_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_csgetptn - - - subroutine d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_csgetrow - - - subroutine d_csc_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_csgetblk - - - subroutine d_csc_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_csclip - - subroutine d_csc_free(a) implicit none @@ -694,903 +429,4 @@ contains end subroutine d_csc_free - subroutine d_csc_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = dzero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_reinit - - subroutine d_csc_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, n - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - n = a%get_ncols() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_trim - - subroutine d_cp_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csc_to_coo - - subroutine d_cp_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csc_from_coo - - - subroutine d_cp_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csc_to_fmt - - subroutine d_cp_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csc_from_fmt - - - subroutine d_mv_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csc_to_coo - - subroutine d_mv_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csc_from_coo - - - subroutine d_mv_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csc_to_fmt - - subroutine d_mv_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csc_from_fmt - - subroutine d_csc_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_d_csc_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%icp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_allocate_mnnz - - - subroutine d_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_d_csc_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='d_csc_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),(i),a%val(j) - end do - enddo - endif - endif - - end subroutine d_csc_print - - - subroutine d_csc_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(out) :: a - type(psb_d_csc_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - a%icp = b%icp - a%ia = b%ia - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_csc_cp_from - - subroutine d_csc_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_csc_sparse_mat), intent(out) :: a - type(psb_d_csc_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_csc_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine d_csc_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csc_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call d_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_csmv - - subroutine d_csc_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call d_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_csmm - - - subroutine d_csc_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csc_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call d_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine d_csc_cssv - - - - subroutine d_csc_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call d_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_cssm - - function d_csc_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = d_csc_csnmi_impl(a) - - return - - end function d_csc_csnmi - - subroutine d_csc_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = dzero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_get_diag - - - subroutine d_csc_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, n - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - n = a%get_ncols() - if (size(d) < n) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, n - do j = a%icp(i), a%icp(i+1) -1 - a%val(j) = a%val(j) * d(a%ia(j)) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_scal - - - subroutine d_csc_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csc_scals - - - end module psb_d_csc_mat_mod diff --git a/base/modules/psb_d_csr_mat_mod.f03 b/base/modules/psb_d_csr_mat_mod.f03 index 2d6fd62c..89dea12d 100644 --- a/base/modules/psb_d_csr_mat_mod.f03 +++ b/base/modules/psb_d_csr_mat_mod.f03 @@ -8,163 +8,195 @@ module psb_d_csr_mat_mod real(psb_dpk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => d_csr_get_nzeros - procedure, pass(a) :: get_fmt => d_csr_get_fmt - procedure, pass(a) :: get_diag => d_csr_get_diag - procedure, pass(a) :: d_base_csmm => d_csr_csmm - procedure, pass(a) :: d_base_csmv => d_csr_csmv - procedure, pass(a) :: d_base_cssm => d_csr_cssm - procedure, pass(a) :: d_base_cssv => d_csr_cssv - procedure, pass(a) :: d_scals => d_csr_scals - procedure, pass(a) :: d_scal => d_csr_scal - procedure, pass(a) :: csnmi => d_csr_csnmi - procedure, pass(a) :: reallocate_nz => d_csr_reallocate_nz - procedure, pass(a) :: csput => d_csr_csput - procedure, pass(a) :: allocate_mnnz => d_csr_allocate_mnnz - procedure, pass(a) :: cp_to_coo => d_cp_csr_to_coo - procedure, pass(a) :: cp_from_coo => d_cp_csr_from_coo - procedure, pass(a) :: cp_to_fmt => d_cp_csr_to_fmt - procedure, pass(a) :: cp_from_fmt => d_cp_csr_from_fmt - procedure, pass(a) :: mv_to_coo => d_mv_csr_to_coo - procedure, pass(a) :: mv_from_coo => d_mv_csr_from_coo - procedure, pass(a) :: mv_to_fmt => d_mv_csr_to_fmt - procedure, pass(a) :: mv_from_fmt => d_mv_csr_from_fmt - procedure, pass(a) :: csgetptn => d_csr_csgetptn - procedure, pass(a) :: d_csgetrow => d_csr_csgetrow - procedure, pass(a) :: get_nz_row => d_csr_get_nz_row - procedure, pass(a) :: get_size => d_csr_get_size - procedure, pass(a) :: free => d_csr_free - procedure, pass(a) :: trim => d_csr_trim - procedure, pass(a) :: print => d_csr_print - procedure, pass(a) :: sizeof => d_csr_sizeof - procedure, pass(a) :: reinit => d_csr_reinit - procedure, pass(a) :: d_csr_cp_from - generic, public :: cp_from => d_csr_cp_from - procedure, pass(a) :: d_csr_mv_from - generic, public :: mv_from => d_csr_mv_from + procedure, pass(a) :: get_size => d_csr_get_size + procedure, pass(a) :: get_nzeros => d_csr_get_nzeros + procedure, pass(a) :: get_fmt => d_csr_get_fmt + procedure, pass(a) :: sizeof => d_csr_sizeof + procedure, pass(a) :: d_csmm => psb_d_csr_csmm + procedure, pass(a) :: d_csmv => psb_d_csr_csmv + procedure, pass(a) :: d_inner_cssm => psb_d_csr_cssm + procedure, pass(a) :: d_inner_cssv => psb_d_csr_cssv + procedure, pass(a) :: d_scals => psb_d_csr_scals + procedure, pass(a) :: d_scal => psb_d_csr_scal + procedure, pass(a) :: csnmi => psb_d_csr_csnmi + procedure, pass(a) :: reallocate_nz => psb_d_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_d_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_d_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_d_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_d_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_d_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_d_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_d_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_d_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_d_mv_csr_from_fmt + procedure, pass(a) :: csput => psb_d_csr_csput + procedure, pass(a) :: get_diag => psb_d_csr_get_diag + procedure, pass(a) :: csgetptn => psb_d_csr_csgetptn + procedure, pass(a) :: d_csgetrow => psb_d_csr_csgetrow + procedure, pass(a) :: get_nz_row => d_csr_get_nz_row + procedure, pass(a) :: reinit => psb_d_csr_reinit + procedure, pass(a) :: trim => psb_d_csr_trim + procedure, pass(a) :: print => psb_d_csr_print + procedure, pass(a) :: free => d_csr_free + procedure, pass(a) :: psb_d_csr_cp_from + generic, public :: cp_from => psb_d_csr_cp_from + procedure, pass(a) :: psb_d_csr_mv_from + generic, public :: mv_from => psb_d_csr_mv_from end type psb_d_csr_sparse_mat - private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, & - & d_csr_csput, d_csr_reallocate_nz, d_csr_allocate_mnnz, & - & d_csr_free, d_csr_print, d_csr_get_fmt, d_csr_csnmi, get_diag, & - & d_cp_csr_to_coo, d_cp_csr_from_coo, & - & d_mv_csr_to_coo, d_mv_csr_from_coo, & - & d_cp_csr_to_fmt, d_cp_csr_from_fmt, & - & d_mv_csr_to_fmt, d_mv_csr_from_fmt, & - & d_csr_scals, d_csr_scal, d_csr_trim, d_csr_csgetrow, d_csr_get_size, & - & d_csr_sizeof, d_csr_csgetptn, d_csr_get_nz_row, d_csr_reinit + private :: d_csr_get_nzeros, d_csr_free, d_csr_get_fmt, & + & d_csr_get_size, d_csr_sizeof, d_csr_get_nz_row - - interface - subroutine d_cp_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + interface + subroutine psb_d_csr_reallocate_nz(nz,a) import psb_d_csr_sparse_mat - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine d_cp_csr_to_fmt_impl + integer, intent(in) :: nz + class(psb_d_csr_sparse_mat), intent(inout) :: a + end subroutine psb_d_csr_reallocate_nz end interface - + interface - subroutine d_cp_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + subroutine psb_d_csr_reinit(a,clear) + import psb_d_csr_sparse_mat + class(psb_d_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_d_csr_reinit + end interface + + interface + subroutine psb_d_csr_trim(a) import psb_d_csr_sparse_mat class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine d_cp_csr_from_fmt_impl + end subroutine psb_d_csr_trim end interface - - - interface - subroutine d_cp_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod + + interface + subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) + import psb_d_csr_sparse_mat + integer, intent(in) :: m,n + class(psb_d_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_d_csr_allocate_mnnz + end interface + + interface + subroutine psb_d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) import psb_d_csr_sparse_mat + integer, intent(in) :: iout + class(psb_d_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_csr_print + end interface + + interface + subroutine psb_d_cp_csr_to_coo(a,b,info) + import psb_d_coo_sparse_mat, psb_d_csr_sparse_mat class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_cp_csr_to_coo_impl + end subroutine psb_d_cp_csr_to_coo end interface - + interface - subroutine d_cp_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csr_sparse_mat + subroutine psb_d_cp_csr_from_coo(a,b,info) + import psb_d_csr_sparse_mat, psb_d_coo_sparse_mat class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine d_cp_csr_from_coo_impl + end subroutine psb_d_cp_csr_from_coo end interface - + interface - subroutine d_mv_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csr_sparse_mat + subroutine psb_d_cp_csr_to_fmt(a,b,info) + import psb_d_csr_sparse_mat, psb_d_base_sparse_mat + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_cp_csr_to_fmt + end interface + + interface + subroutine psb_d_cp_csr_from_fmt(a,b,info) + import psb_d_csr_sparse_mat, psb_d_base_sparse_mat + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_d_cp_csr_from_fmt + end interface + + interface + subroutine psb_d_mv_csr_to_coo(a,b,info) + import psb_d_csr_sparse_mat, psb_d_coo_sparse_mat class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_csr_to_fmt_impl + end subroutine psb_d_mv_csr_to_coo end interface - + interface - subroutine d_mv_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csr_sparse_mat + subroutine psb_d_mv_csr_from_coo(a,b,info) + import psb_d_csr_sparse_mat, psb_d_coo_sparse_mat + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_mv_csr_from_coo + end interface + + interface + subroutine psb_d_mv_csr_to_fmt(a,b,info) + import psb_d_csr_sparse_mat, psb_d_base_sparse_mat + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_d_mv_csr_to_fmt + end interface + + interface + subroutine psb_d_mv_csr_from_fmt(a,b,info) + import psb_d_csr_sparse_mat, psb_d_base_sparse_mat class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine d_mv_csr_from_fmt_impl + end subroutine psb_d_mv_csr_from_fmt end interface - - + interface - subroutine d_mv_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csr_sparse_mat + subroutine psb_d_csr_cp_from(a,b) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine d_mv_csr_to_coo_impl + type(psb_d_csr_sparse_mat), intent(in) :: b + end subroutine psb_d_csr_cp_from end interface - + interface - subroutine d_mv_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_d_base_mat_mod - import psb_d_csr_sparse_mat - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine d_mv_csr_from_coo_impl + subroutine psb_d_csr_mv_from(a,b) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(inout) :: a + type(psb_d_csr_sparse_mat), intent(inout) :: b + end subroutine psb_d_csr_mv_from end interface - + + interface - subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_d_csr_sparse_mat + subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_csr_csput_impl + end subroutine psb_d_csr_csput end interface - + interface - subroutine d_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_d_csr_sparse_mat - implicit none - + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -174,16 +206,13 @@ module psb_d_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_csr_csgetptn_impl + end subroutine psb_d_csr_csgetptn end interface - + interface - subroutine d_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_d_csr_sparse_mat - implicit none - + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -194,58 +223,96 @@ module psb_d_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine d_csr_csgetrow_impl + end subroutine psb_d_csr_csgetrow end interface - interface d_csr_cssm_impl - subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csr_sparse_mat + interface + subroutine psb_d_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_d_csr_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csr_csgetblk + end interface + + interface + subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csr_cssv_impl - subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csr_sparse_mat + end subroutine psb_d_csr_cssv + subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csr_cssm_impl + end subroutine psb_d_csr_cssm end interface - - interface d_csr_csmm_impl - subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csr_sparse_mat + + interface + subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csr_csmv_impl - subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_d_csr_sparse_mat + end subroutine psb_d_csr_csmv + subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine d_csr_csmm_impl + end subroutine psb_d_csr_csmm end interface - - interface d_csr_csnmi_impl - function d_csr_csnmi_impl(a) result(res) - use psb_const_mod - import psb_d_csr_sparse_mat + + + interface + function psb_d_csr_csnmi(a) result(res) + import psb_d_csr_sparse_mat, psb_dpk_ class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function d_csr_csnmi_impl + end function psb_d_csr_csnmi + end interface + + interface + subroutine psb_d_csr_get_diag(a,d,info) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_csr_get_diag + end interface + + interface + subroutine psb_d_csr_scal(d,a,info) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_csr_scal + end interface + + interface + subroutine psb_d_csr_scals(d,a,info) + import psb_d_csr_sparse_mat, psb_dpk_ + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_d_csr_scals end interface @@ -317,7 +384,7 @@ contains function d_csr_get_nz_row(idx,a) result(res) - use psb_const_mod + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a @@ -346,341 +413,6 @@ contains ! !===================================== - - subroutine d_csr_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_d_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='d_csr_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& - & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_reallocate_nz - - subroutine d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='d_csr_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_csr_csput - - subroutine d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call d_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_csgetptn - - - subroutine d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call d_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_csgetrow - - - subroutine d_csr_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_csgetblk - - - subroutine d_csr_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_csclip - - subroutine d_csr_free(a) implicit none @@ -697,906 +429,5 @@ contains end subroutine d_csr_free - subroutine d_csr_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = dzero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_reinit - - - subroutine d_csr_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, m - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - m = a%get_nrows() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_trim - - - subroutine d_cp_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csr_to_coo - - subroutine d_cp_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csr_from_coo - - - subroutine d_cp_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csr_to_fmt - - subroutine d_cp_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_cp_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_cp_csr_from_fmt - - - subroutine d_mv_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csr_to_coo - - subroutine d_mv_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csr_from_coo - - - subroutine d_mv_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csr_to_fmt - - subroutine d_mv_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call d_mv_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_mv_csr_from_fmt - - - subroutine d_csr_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_d_csr_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%irp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_allocate_mnnz - - - subroutine d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_d_csr_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='d_csr_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),(a%ja(j)),a%val(j) - end do - enddo - endif - endif - - end subroutine d_csr_print - - - subroutine d_csr_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(out) :: a - type(psb_d_csr_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - a%irp = b%irp - a%ja = b%ja - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_csr_cp_from - - subroutine d_csr_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_d_csr_sparse_mat), intent(out) :: a - type(psb_d_csr_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine d_csr_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine d_csr_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csr_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call d_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_csmv - - subroutine d_csr_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call d_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_csmm - - - subroutine d_csr_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csr_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine d_csr_cssv - - - - subroutine d_csr_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='d_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_cssm - - function d_csr_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = d_csr_csnmi_impl(a) - - return - - end function d_csr_csnmi - - subroutine d_csr_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = dzero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_get_diag - - - subroutine d_csr_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 - a%val(j) = a%val(j) * d(i) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_scal - - - subroutine d_csr_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csr_scals - - end module psb_d_csr_mat_mod diff --git a/base/modules/psb_d_mat_mod.f03 b/base/modules/psb_d_mat_mod.f03 index e194d304..e12953a2 100644 --- a/base/modules/psb_d_mat_mod.f03 +++ b/base/modules/psb_d_mat_mod.f03 @@ -9,20 +9,6 @@ module psb_d_mat_mod class(psb_d_base_sparse_mat), allocatable :: a contains - ! Setters - procedure, pass(a) :: set_nrows - procedure, pass(a) :: set_ncols - procedure, pass(a) :: set_dupl - procedure, pass(a) :: set_state - procedure, pass(a) :: set_null - procedure, pass(a) :: set_bld - procedure, pass(a) :: set_upd - procedure, pass(a) :: set_asb - procedure, pass(a) :: set_sorted - procedure, pass(a) :: set_upper - procedure, pass(a) :: set_lower - procedure, pass(a) :: set_triangle - procedure, pass(a) :: set_unit ! Getters procedure, pass(a) :: get_nrows procedure, pass(a) :: get_ncols @@ -40,109 +26,574 @@ module psb_d_mat_mod procedure, pass(a) :: is_lower procedure, pass(a) :: is_triangle procedure, pass(a) :: is_unit - procedure, pass(a) :: get_fmt => sparse_get_fmt - procedure, pass(a) :: sizeof => d_sizeof + procedure, pass(a) :: get_fmt => psb_d_get_fmt + procedure, pass(a) :: sizeof => psb_d_sizeof + ! Setters + procedure, pass(a) :: set_nrows => psb_d_set_nrows + procedure, pass(a) :: set_ncols => psb_d_set_ncols + procedure, pass(a) :: set_dupl => psb_d_set_dupl + procedure, pass(a) :: set_state => psb_d_set_state + procedure, pass(a) :: set_null => psb_d_set_null + procedure, pass(a) :: set_bld => psb_d_set_bld + procedure, pass(a) :: set_upd => psb_d_set_upd + procedure, pass(a) :: set_asb => psb_d_set_asb + procedure, pass(a) :: set_sorted => psb_d_set_sorted + procedure, pass(a) :: set_upper => psb_d_set_upper + procedure, pass(a) :: set_lower => psb_d_set_lower + procedure, pass(a) :: set_triangle => psb_d_set_triangle + procedure, pass(a) :: set_unit => psb_d_set_unit ! Memory/data management - procedure, pass(a) :: csall - procedure, pass(a) :: free - procedure, pass(a) :: trim - procedure, pass(a) :: csput - procedure, pass(a) :: d_csgetptn - procedure, pass(a) :: d_csgetrow - procedure, pass(a) :: d_csgetblk + procedure, pass(a) :: csall => psb_d_csall + procedure, pass(a) :: free => psb_d_free + procedure, pass(a) :: trim => psb_d_trim + procedure, pass(a) :: csput => psb_d_csput + procedure, pass(a) :: d_csgetptn => psb_d_csgetptn + procedure, pass(a) :: d_csgetrow => psb_d_csgetrow + procedure, pass(a) :: d_csgetblk => psb_d_csgetblk generic, public :: csget => d_csgetptn, d_csgetrow, d_csgetblk - procedure, pass(a) :: d_csclip - procedure, pass(a) :: d_b_csclip + procedure, pass(a) :: d_csclip => psb_d_csclip + procedure, pass(a) :: d_b_csclip => psb_d_b_csclip generic, public :: csclip => d_b_csclip, d_csclip - procedure, pass(a) :: d_clip_d_ip - procedure, pass(a) :: d_clip_d + procedure, pass(a) :: d_clip_d_ip => psb_d_clip_d_ip + procedure, pass(a) :: d_clip_d => psb_d_clip_d generic, public :: clip_diag => d_clip_d_ip, d_clip_d - procedure, pass(a) :: reall => reallocate_nz - procedure, pass(a) :: get_neigh - procedure, pass(a) :: d_cscnv - procedure, pass(a) :: d_cscnv_ip - procedure, pass(a) :: d_cscnv_base + procedure, pass(a) :: reall => psb_d_reallocate_nz + procedure, pass(a) :: get_neigh => psb_d_get_neigh + procedure, pass(a) :: d_cscnv => psb_d_cscnv + procedure, pass(a) :: d_cscnv_ip => psb_d_cscnv_ip + procedure, pass(a) :: d_cscnv_base => psb_d_cscnv_base generic, public :: cscnv => d_cscnv, d_cscnv_ip, d_cscnv_base - procedure, pass(a) :: reinit - procedure, pass(a) :: print => sparse_print - procedure, pass(a) :: d_mv_from + procedure, pass(a) :: reinit => psb_d_reinit + procedure, pass(a) :: print => psb_d_sparse_print + procedure, pass(a) :: d_mv_from => psb_d_mv_from generic, public :: mv_from => d_mv_from - procedure, pass(a) :: d_mv_to + procedure, pass(a) :: d_mv_to => psb_d_mv_to generic, public :: mv_to => d_mv_to - procedure, pass(a) :: d_cp_from + procedure, pass(a) :: d_cp_from => psb_d_cp_from generic, public :: cp_from => d_cp_from - procedure, pass(a) :: d_cp_to + procedure, pass(a) :: d_cp_to => psb_d_cp_to generic, public :: cp_to => d_cp_to - procedure, pass(a) :: d_transp_1mat - procedure, pass(a) :: d_transp_2mat + procedure, pass(a) :: d_transp_1mat => psb_d_transp_1mat + procedure, pass(a) :: d_transp_2mat => psb_d_transp_2mat generic, public :: transp => d_transp_1mat, d_transp_2mat - procedure, pass(a) :: d_transc_1mat - procedure, pass(a) :: d_transc_2mat + procedure, pass(a) :: d_transc_1mat => psb_d_transc_1mat + procedure, pass(a) :: d_transc_2mat => psb_d_transc_2mat generic, public :: transc => d_transc_1mat, d_transc_2mat ! Computational routines - procedure, pass(a) :: get_diag - procedure, pass(a) :: csnmi - procedure, pass(a) :: d_csmv - procedure, pass(a) :: d_csmm + procedure, pass(a) :: get_diag => psb_d_get_diag + procedure, pass(a) :: csnmi => psb_d_csnmi + procedure, pass(a) :: d_csmv => psb_d_csmv + procedure, pass(a) :: d_csmm => psb_d_csmm generic, public :: csmm => d_csmm, d_csmv - procedure, pass(a) :: d_scals - procedure, pass(a) :: d_scal - generic, public :: scal => d_scals, d_scal - procedure, pass(a) :: d_cssv - procedure, pass(a) :: d_cssm + procedure, pass(a) :: d_scals => psb_d_scals + procedure, pass(a) :: d_scal => psb_d_scal + generic, public :: scal => d_scals, d_scal + procedure, pass(a) :: d_cssv => psb_d_cssv + procedure, pass(a) :: d_cssm => psb_d_cssm generic, public :: cssm => d_cssm, d_cssv end type psb_d_sparse_mat private :: get_nrows, get_ncols, get_nzeros, get_size, & & get_state, get_dupl, is_null, is_bld, is_upd, & - & is_asb, is_sorted, is_upper, is_lower, is_triangle, & - & is_unit, get_neigh, csall, csput, d_csgetrow, d_clip_d_ip, d_clip_d,& - & d_csgetblk, d_csclip, d_b_csclip, d_cscnv, d_cscnv_ip, & - & reallocate_nz, free, trim, & - & sparse_print, reinit, & - & set_nrows, set_ncols, set_dupl, & - & set_state, set_null, set_bld, & - & set_upd, set_asb, set_sorted, & - & set_upper, set_lower, set_triangle, & - & set_unit, get_diag, get_nz_row, d_csgetptn, & - & d_mv_from, d_mv_to, d_cp_from, d_cp_to,& - & d_transp_1mat, d_transp_2mat, & - & d_transc_1mat, d_transc_2mat + & is_asb, is_sorted, is_upper, is_lower, is_triangle interface psb_sizeof - module procedure d_sizeof + module procedure psb_d_sizeof + end interface + + + !===================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !===================================== + + + interface + subroutine psb_d_set_nrows(m,a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + end subroutine psb_d_set_nrows + end interface + + interface + subroutine psb_d_set_ncols(n,a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_d_set_ncols + end interface + + interface + subroutine psb_d_set_state(n,a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_d_set_state + end interface + + interface + subroutine psb_d_set_dupl(n,a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_d_set_dupl + end interface + + interface + subroutine psb_d_set_null(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_set_null + end interface + + interface + subroutine psb_d_set_bld(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_set_bld + end interface + + interface + subroutine psb_d_set_upd(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_set_upd + end interface + + interface + subroutine psb_d_set_asb(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_set_asb + end interface + + interface + subroutine psb_d_set_sorted(a,val) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_sorted + end interface + + interface + subroutine psb_d_set_triangle(a,val) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_triangle + end interface + + interface + subroutine psb_d_set_unit(a,val) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_unit + end interface + + interface + subroutine psb_d_set_lower(a,val) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_lower + end interface + + interface + subroutine psb_d_set_upper(a,val) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_upper + end interface + + + interface + subroutine psb_d_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_d_sparse_mat + integer, intent(in) :: iout + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_sparse_print + end interface + + interface + subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_d_get_neigh + end interface + + interface + subroutine psb_d_csall(nr,nc,a,info,nz) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + end subroutine psb_d_csall + end interface + + interface + subroutine psb_d_reallocate_nz(nz,a) + import psb_d_sparse_mat + integer, intent(in) :: nz + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_reallocate_nz + end interface + + interface + subroutine psb_d_free(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_free + end interface + + interface + subroutine psb_d_trim(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_trim + end interface + + interface + subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_d_csput + end interface + + interface + subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csgetptn + end interface + + interface + subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csgetrow + end interface + + interface + subroutine psb_d_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csgetblk + end interface + + interface + subroutine psb_d_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csclip + end interface + + interface + subroutine psb_d_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_d_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_b_csclip end interface + + interface + subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_d_cscnv + end interface + + + interface + subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(out) :: iinfo + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_d_cscnv_ip + end interface + + interface + subroutine psb_d_cscnv_base(a,b,info,dupl) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + end subroutine psb_d_cscnv_base + end interface + + interface + subroutine psb_d_clip_d(a,b,info) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer,intent(out) :: info + end subroutine psb_d_clip_d + end interface + + interface + subroutine psb_d_clip_d_ip(a,info) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + end subroutine psb_d_clip_d_ip + end interface + + interface + subroutine psb_d_mv_from(a,b) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_mv_from + end interface + + interface + subroutine psb_d_cp_from(a,b) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + end subroutine psb_d_cp_from + end interface + + interface + subroutine psb_d_mv_to(a,b) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + end subroutine psb_d_mv_to + end interface + + interface + subroutine psb_d_cp_to(a,b) + import psb_d_sparse_mat, psb_dpk_, psb_d_base_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + end subroutine psb_d_cp_to + end interface + interface psb_move_alloc - module procedure d_sparse_mat_move + subroutine psb_d_sparse_mat_move(a,b,info) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_d_sparse_mat_move end interface + interface psb_clone - module procedure d_sparse_mat_clone + subroutine psb_d_sparse_mat_clone(a,b,info) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_d_sparse_mat_clone + end interface + + interface + subroutine psb_d_transp_1mat(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_transp_1mat + end interface + + interface + subroutine psb_d_transp_2mat(a,b) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_sparse_mat), intent(in) :: b + end subroutine psb_d_transp_2mat + end interface + + interface + subroutine psb_d_transc_1mat(a) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + end subroutine psb_d_transc_1mat + end interface + + interface + subroutine psb_d_transc_2mat(a,b) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_sparse_mat), intent(in) :: b + end subroutine psb_d_transc_2mat + end interface + + interface + subroutine psb_d_reinit(a,clear) + import psb_d_sparse_mat + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_d_reinit + end interface + + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== interface psb_csmm - module procedure d_csmm, d_csmv + subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_csmm + subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_csmv end interface - + interface psb_cssm - module procedure d_cssm, d_cssv + subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_d_cssm + subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_d_cssv end interface - - interface psb_csnmi - module procedure csnmi + + interface + function psb_d_csnmi(a) result(res) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_csnmi + end interface + + interface + subroutine psb_d_get_diag(a,d,info) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_get_diag end interface interface psb_scal - module procedure d_scals, d_scal + subroutine psb_d_scal(d,a,info) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_d_scal + subroutine psb_d_scals(d,a,info) + import psb_d_sparse_mat, psb_dpk_ + class(psb_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_d_scals end interface + + + contains @@ -159,7 +610,7 @@ contains !===================================== - function d_sizeof(a) result(res) + function psb_d_sizeof(a) result(res) implicit none class(psb_d_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res @@ -169,11 +620,11 @@ contains res = a%a%sizeof() end if - end function d_sizeof + end function psb_d_sizeof - function sparse_get_fmt(a) result(res) + function psb_d_get_fmt(a) result(res) implicit none class(psb_d_sparse_mat), intent(in) :: a character(len=5) :: res @@ -184,12 +635,11 @@ contains res = 'NULL' end if - end function sparse_get_fmt + end function psb_d_get_fmt function get_dupl(a) result(res) - use psb_error_mod implicit none class(psb_d_sparse_mat), intent(in) :: a integer :: res @@ -360,73 +810,33 @@ contains function get_nzeros(a) result(res) - use psb_error_mod implicit none class(psb_d_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_nzeros() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() end if end function get_nzeros function get_size(a) result(res) - use psb_error_mod + implicit none class(psb_d_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_size' - logical, parameter :: debug=.false. - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_size() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() end if - return end function get_size function get_nz_row(idx,a) result(res) - use psb_error_mod implicit none integer, intent(in) :: idx class(psb_d_sparse_mat), intent(in) :: a @@ -441,1897 +851,4 @@ contains end function get_nz_row - - !===================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine set_nrows(m,a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - integer, intent(in) :: m - Integer :: err_act, info - character(len=20) :: name='set_nrows' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_nrows(m) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_nrows - - subroutine set_ncols(n,a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_ncols(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_ncols - - - subroutine set_state(n,a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_state(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_state - - - subroutine set_dupl(n,a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_dupl(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_dupl - - subroutine set_null(a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_null() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_null - - subroutine set_bld(a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_bld() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_bld - - subroutine set_upd(a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upd() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_upd - - subroutine set_asb(a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_asb() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_asb - - subroutine set_sorted(a,val) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_sorted(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_sorted - - subroutine set_triangle(a,val) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_triangle(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_triangle - - subroutine set_unit(a,val) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_unit(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_unit - - subroutine set_lower(a,val) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_lower(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_lower - - subroutine set_upper(a,val) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upper(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_upper - - - !===================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !===================================== - - - subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_error_mod - implicit none - - integer, intent(in) :: iout - class(psb_d_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act, info - character(len=20) :: name='sparse_print' - logical, parameter :: debug=.false. - - info = 0 - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine sparse_print - - - - subroutine get_neigh(a,idx,neigh,n,info,lev) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable, intent(out) :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - - Integer :: err_act - character(len=20) :: name='get_neigh' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_neigh(idx,neigh,n,info,lev) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_neigh - - - subroutine csall(nr,nc,a,info,nz) - use psb_d_base_mat_mod - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(out) :: a - integer, intent(in) :: nr,nc - integer, intent(out) :: info - integer, intent(in), optional :: nz - - Integer :: err_act - character(len=20) :: name='csall' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - allocate(psb_d_coo_sparse_mat :: a%a, stat=info) - if (info /= 0) then - info = 4000 - call psb_errpush(info, name) - goto 9999 - end if - call a%a%allocate(nr,nc,nz) - call a%set_bld() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csall - - subroutine reallocate_nz(nz,a) - use psb_error_mod - implicit none - integer, intent(in) :: nz - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='reallocate_nz' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reallocate(nz) - - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine reallocate_nz - - subroutine free(a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='free' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%free() - deallocate(a%a) - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine free - - subroutine trim(a) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%trim() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine trim - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_d_base_mat_mod - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.a%is_bld()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csput - - subroutine d_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_csgetptn - - subroutine d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_csgetrow - - - - subroutine d_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_sparse_mat), intent(out) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat), allocatable :: acoo - - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - - if (info == 0) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_csgetblk - - - - subroutine d_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csclip' - logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat), allocatable :: acoo - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_csclip - - subroutine d_b_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(in) :: a - type(psb_d_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csclip' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csclip(b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_b_csclip - - - - subroutine d_cscnv(a,b,info,type,mold,upd,dupl) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_sparse_mat), intent(out) :: b - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_d_base_sparse_mat), intent(in), optional :: mold - - - class(psb_d_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call b%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call b%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - call b%set_asb() - call b%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_cscnv - - - subroutine d_cscnv_ip(a,info,type,mold,dupl) - use psb_error_mod - use psb_string_mod - implicit none - - class(psb_d_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_d_base_sparse_mat), intent(in), optional :: mold - - - class(psb_d_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv_ip' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - 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 = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%mv_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,a%a) - call a%set_asb() - call a%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_cscnv_ip - - - subroutine d_cscnv_base(a,b,info,dupl) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - integer,optional, intent(in) :: dupl - - - type(psb_d_coo_sparse_mat) :: altmp - Integer :: err_act - character(len=20) :: name='cscnv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cp_to_coo(altmp,info ) - if ((info == 0).and.present(dupl)) then - call altmp%set_dupl(dupl) - end if - call altmp%fix(info) - if (info == 0) call altmp%trim() - if (info == 0) call altmp%set_asb() - if (info == 0) call b%mv_from_coo(altmp,info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_cscnv_base - - - subroutine d_clip_d(a,b,info) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_sparse_mat), intent(out) :: b - integer,intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clip_diag' - logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat), allocatable :: acoo - integer :: i, j, nz - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%cp_to_coo(acoo,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - nz = acoo%get_nzeros() - j = 0 - do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 - acoo%ia(j) = acoo%ia(i) - acoo%ja(j) = acoo%ja(i) - acoo%val(j) = acoo%val(i) - end if - end do - call acoo%set_nzeros(j) - call acoo%trim() - call b%mv_from(acoo) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_clip_d - - - subroutine d_clip_d_ip(a,info) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_d_base_mat_mod - implicit none - - class(psb_d_sparse_mat), intent(inout) :: a - integer,intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clip_diag' - logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat), allocatable :: acoo - integer :: i, j, nz - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%mv_to_coo(acoo,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - nz = acoo%get_nzeros() - j = 0 - do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 - acoo%ia(j) = acoo%ia(i) - acoo%ja(j) = acoo%ja(i) - acoo%val(j) = acoo%val(i) - end if - end do - call acoo%set_nzeros(j) - call acoo%trim() - call a%mv_from(acoo) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_clip_d_ip - - subroutine d_mv_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(out) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer :: info - - allocate(a%a,source=b, stat=info) - call a%a%mv_from_fmt(b,info) - - return - end subroutine d_mv_from - - subroutine d_cp_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(out) :: a - class(psb_d_base_sparse_mat), intent(inout), allocatable :: b - Integer :: err_act, info - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine d_cp_from - - subroutine d_mv_to(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer :: info - - call b%mv_from_fmt(a%a,info) - - return - end subroutine d_mv_to - - subroutine d_cp_to(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer :: info - - call b%cp_from_fmt(a%a,info) - - return - end subroutine d_cp_to - - - subroutine d_sparse_mat_move(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - class(psb_d_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='move_alloc' - logical, parameter :: debug=.false. - - info = 0 - call move_alloc(a%a,b%a) - - return - end subroutine d_sparse_mat_move - - subroutine d_sparse_mat_clone(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - class(psb_d_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_sparse_mat_clone - - - subroutine d_transp_1mat(a) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - - Integer :: err_act, info - character(len=20) :: name='transp' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%transp() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_transp_1mat - - - subroutine d_transp_2mat(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(out) :: a - class(psb_d_sparse_mat), intent(in) :: b - - Integer :: err_act, info - character(len=20) :: name='transp' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (b%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 - goto 9999 - end if - call a%a%transp(b%a) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_transp_2mat - - subroutine d_transc_1mat(a) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - - Integer :: err_act, info - character(len=20) :: name='transc' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%transc() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_transc_1mat - - - subroutine d_transc_2mat(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_d_sparse_mat), intent(out) :: a - class(psb_d_sparse_mat), intent(in) :: b - - Integer :: err_act, info - character(len=20) :: name='transc' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (b%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 - goto 9999 - end if - call a%a%transc(b%a) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine d_transc_2mat - - - - subroutine reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_d_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - Integer :: err_act, info - character(len=20) :: name='reinit' - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reinit(clear) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine reinit - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine d_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csmm - - subroutine d_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_csmv - - subroutine d_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cssm - - subroutine d_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_cssv - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%csnmi() - - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end function csnmi - - - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_diag(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_diag - - subroutine d_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_scal - - subroutine d_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_d_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_scals - - end module psb_d_mat_mod diff --git a/base/modules/psb_s_base_mat_mod.f03 b/base/modules/psb_s_base_mat_mod.f03 index a901e34a..b07ed001 100644 --- a/base/modules/psb_s_base_mat_mod.f03 +++ b/base/modules/psb_s_base_mat_mod.f03 @@ -1,54 +1,52 @@ module psb_s_base_mat_mod use psb_base_mat_mod - + type, extends(psb_base_sparse_mat) :: psb_s_base_sparse_mat contains - procedure, pass(a) :: s_base_csmv - procedure, pass(a) :: s_base_csmm - generic, public :: csmm => s_base_csmm, s_base_csmv - procedure, pass(a) :: s_base_cssv - procedure, pass(a) :: s_base_cssm - generic, public :: base_cssm => s_base_cssm, s_base_cssv - procedure, pass(a) :: s_cssv - procedure, pass(a) :: s_cssm - generic, public :: cssm => s_cssm, s_cssv - procedure, pass(a) :: s_scals - procedure, pass(a) :: s_scal - generic, public :: scal => s_scals, s_scal - procedure, pass(a) :: csnmi - procedure, pass(a) :: get_diag - procedure, pass(a) :: csput - - procedure, pass(a) :: s_csgetrow - procedure, pass(a) :: s_csgetblk - generic, public :: csget => s_csgetrow, s_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: cp_to_coo - procedure, pass(a) :: cp_from_coo - procedure, pass(a) :: cp_to_fmt - procedure, pass(a) :: cp_from_fmt - procedure, pass(a) :: mv_to_coo - procedure, pass(a) :: mv_from_coo - procedure, pass(a) :: mv_to_fmt - procedure, pass(a) :: mv_from_fmt + procedure, pass(a) :: s_csmv => psb_s_base_csmv + procedure, pass(a) :: s_csmm => psb_s_base_csmm + generic, public :: csmm => s_csmm, s_csmv + procedure, pass(a) :: s_inner_cssv => psb_s_base_inner_cssv + procedure, pass(a) :: s_inner_cssm => psb_s_base_inner_cssm + generic, public :: inner_cssm => s_inner_cssm, s_inner_cssv + procedure, pass(a) :: s_cssv => psb_s_base_cssv + procedure, pass(a) :: s_cssm => psb_s_base_cssm + generic, public :: cssm => s_cssm, s_cssv + procedure, pass(a) :: s_scals => psb_s_base_scals + procedure, pass(a) :: s_scal => psb_s_base_scal + generic, public :: scal => s_scals, s_scal + procedure, pass(a) :: csnmi => psb_s_base_csnmi + procedure, pass(a) :: get_diag => psb_s_base_get_diag + + procedure, pass(a) :: csput => psb_s_base_csput + procedure, pass(a) :: s_csgetrow => psb_s_base_csgetrow + procedure, pass(a) :: s_csgetblk => psb_s_base_csgetblk + generic, public :: csget => s_csgetrow, s_csgetblk + procedure, pass(a) :: csclip => psb_s_base_csclip + procedure, pass(a) :: cp_to_coo => psb_s_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_s_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_s_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_s_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_s_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_s_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_s_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_s_base_mv_from_fmt procedure, pass(a) :: s_base_cp_from generic, public :: cp_from => s_base_cp_from procedure, pass(a) :: s_base_mv_from generic, public :: mv_from => s_base_mv_from - - procedure, pass(a) :: base_transp_1mat => s_base_transp_1mat - procedure, pass(a) :: base_transp_2mat => s_base_transp_2mat - procedure, pass(a) :: base_transc_1mat => s_base_transc_1mat - procedure, pass(a) :: base_transc_2mat => s_base_transc_2mat + + procedure, pass(a) :: transp_1mat => psb_s_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_s_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_s_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_s_base_transc_2mat + end type psb_s_base_sparse_mat - - private :: s_base_csmv, s_base_csmm, s_base_cssv, s_base_cssm,& - & s_scals, s_scal, csnmi, csput, s_csgetrow, s_csgetblk, & - & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & - & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & - & get_diag, csclip, s_cssv, s_cssm, base_cp_from, base_mv_from - + + private :: s_base_cssv, s_base_cssm, s_base_cp_from, s_base_mv_from + + type, extends(psb_s_base_sparse_mat) :: psb_s_coo_sparse_mat integer :: nnz @@ -57,181 +55,511 @@ module psb_s_base_mat_mod contains - procedure, pass(a) :: get_size => s_coo_get_size - procedure, pass(a) :: get_nzeros => s_coo_get_nzeros - procedure, pass(a) :: set_nzeros => s_coo_set_nzeros - procedure, pass(a) :: s_base_csmm => s_coo_csmm - procedure, pass(a) :: s_base_csmv => s_coo_csmv - procedure, pass(a) :: s_base_cssm => s_coo_cssm - procedure, pass(a) :: s_base_cssv => s_coo_cssv - procedure, pass(a) :: s_scals => s_coo_scals - procedure, pass(a) :: s_scal => s_coo_scal - procedure, pass(a) :: csnmi => s_coo_csnmi - procedure, pass(a) :: csput => s_coo_csput - procedure, pass(a) :: get_diag => s_coo_get_diag - procedure, pass(a) :: reallocate_nz => s_coo_reallocate_nz - procedure, pass(a) :: allocate_mnnz => s_coo_allocate_mnnz - procedure, pass(a) :: cp_to_coo => s_cp_coo_to_coo - procedure, pass(a) :: cp_from_coo => s_cp_coo_from_coo - procedure, pass(a) :: cp_to_fmt => s_cp_coo_to_fmt - procedure, pass(a) :: cp_from_fmt => s_cp_coo_from_fmt - procedure, pass(a) :: mv_to_coo => s_mv_coo_to_coo - procedure, pass(a) :: mv_from_coo => s_mv_coo_from_coo - procedure, pass(a) :: mv_to_fmt => s_mv_coo_to_fmt - procedure, pass(a) :: mv_from_fmt => s_mv_coo_from_fmt - procedure, pass(a) :: fix => s_fix_coo - procedure, pass(a) :: free => s_coo_free - procedure, pass(a) :: trim => s_coo_trim - procedure, pass(a) :: s_csgetrow => s_coo_csgetrow - procedure, pass(a) :: csgetptn => s_coo_csgetptn - procedure, pass(a) :: print => s_coo_print - procedure, pass(a) :: get_fmt => s_coo_get_fmt - procedure, pass(a) :: get_nz_row => s_coo_get_nz_row - procedure, pass(a) :: sizeof => s_coo_sizeof - procedure, pass(a) :: reinit => s_coo_reinit - procedure, pass(a) :: s_coo_cp_from - generic, public :: cp_from => s_coo_cp_from - procedure, pass(a) :: s_coo_mv_from - generic, public :: mv_from => s_coo_mv_from - procedure, pass(a) :: base_transp_1mat => s_coo_transp_1mat - procedure, pass(a) :: base_transc_1mat => s_coo_transc_1mat + procedure, pass(a) :: get_size => s_coo_get_size + procedure, pass(a) :: get_nzeros => s_coo_get_nzeros + procedure, pass(a) :: set_nzeros => s_coo_set_nzeros + procedure, pass(a) :: get_fmt => s_coo_get_fmt + procedure, pass(a) :: sizeof => s_coo_sizeof + procedure, pass(a) :: s_csmm => psb_s_coo_csmm + procedure, pass(a) :: s_csmv => psb_s_coo_csmv + procedure, pass(a) :: s_inner_cssm => psb_s_coo_cssm + procedure, pass(a) :: s_inner_cssv => psb_s_coo_cssv + procedure, pass(a) :: s_scals => psb_s_coo_scals + procedure, pass(a) :: s_scal => psb_s_coo_scal + procedure, pass(a) :: csnmi => psb_s_coo_csnmi + procedure, pass(a) :: reallocate_nz => psb_s_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_s_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_s_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_s_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_s_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_s_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_s_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_s_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_s_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_s_mv_coo_from_fmt + procedure, pass(a) :: csput => psb_s_coo_csput + procedure, pass(a) :: get_diag => psb_s_coo_get_diag + procedure, pass(a) :: s_csgetrow => psb_s_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_s_coo_csgetptn + procedure, pass(a) :: get_nz_row => psb_s_coo_get_nz_row + procedure, pass(a) :: reinit => psb_s_coo_reinit + procedure, pass(a) :: fix => psb_s_fix_coo + procedure, pass(a) :: trim => psb_s_coo_trim + procedure, pass(a) :: print => psb_s_coo_print + procedure, pass(a) :: free => s_coo_free + procedure, pass(a) :: psb_s_coo_cp_from + generic, public :: cp_from => psb_s_coo_cp_from + procedure, pass(a) :: psb_s_coo_mv_from + generic, public :: mv_from => psb_s_coo_mv_from + procedure, pass(a) :: transp_1mat => s_coo_transp_1mat + procedure, pass(a) :: transc_1mat => s_coo_transc_1mat end type psb_s_coo_sparse_mat - - private :: s_coo_get_nzeros, s_coo_set_nzeros, s_coo_get_diag, & - & s_coo_csmm, s_coo_csmv, s_coo_cssm, s_coo_cssv, s_coo_csnmi, & - & s_coo_csput, s_coo_reallocate_nz, s_coo_allocate_mnnz, & - & s_fix_coo, s_coo_free, s_coo_print, s_coo_get_fmt, & - & s_cp_coo_to_coo, s_cp_coo_from_coo, & - & s_cp_coo_to_fmt, s_cp_coo_from_fmt, & - & s_coo_scals, s_coo_scal, s_coo_csgetrow, s_coo_sizeof, & - & s_coo_csgetptn, s_coo_get_nz_row, s_coo_reinit,& - & s_coo_cp_from, s_coo_mv_from, & + + private :: s_coo_get_nzeros, s_coo_set_nzeros, & + & s_coo_get_fmt, s_coo_free, s_coo_sizeof, & & s_coo_transp_1mat, s_coo_transc_1mat - - + + + + !=================== + ! + ! BASE interfaces + ! + !=================== + + + interface + subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_base_csmm + end interface + + interface + subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_base_csmv + end interface + + interface + subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_base_inner_cssm + end interface + + interface + subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_base_inner_cssv + end interface + + interface + subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_s_base_cssm + end interface + + interface + subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_s_base_cssv + end interface + + interface + subroutine psb_s_base_scals(d,a,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_s_base_scals + end interface + + interface + subroutine psb_s_base_scal(d,a,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_base_scal + end interface + + interface + function psb_s_base_csnmi(a) result(res) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_s_base_csnmi + end interface + + interface + subroutine psb_s_base_get_diag(a,d,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_base_get_diag + end interface + + interface + subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_s_base_csput + end interface + + interface + subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_base_csgetrow + end interface + + interface + subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_base_csgetblk + end interface + + + interface + subroutine psb_s_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_base_csclip + end interface + + + interface + subroutine psb_s_base_cp_to_coo(a,b,info) + import psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_base_cp_to_coo + end interface + + interface + subroutine psb_s_base_cp_from_coo(a,b,info) + import psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_s_base_cp_from_coo + end interface + + interface + subroutine psb_s_base_cp_to_fmt(a,b,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_base_cp_to_fmt + end interface + + interface + subroutine psb_s_base_cp_from_fmt(a,b,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_s_base_cp_from_fmt + end interface + + interface + subroutine psb_s_base_mv_to_coo(a,b,info) + import psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_base_mv_to_coo + end interface + + interface + subroutine psb_s_base_mv_from_coo(a,b,info) + import psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_base_mv_from_coo + end interface + + interface + subroutine psb_s_base_mv_to_fmt(a,b,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_base_mv_to_fmt + end interface + + interface + subroutine psb_s_base_mv_from_fmt(a,b,info) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_base_mv_from_fmt + end interface + + interface + subroutine psb_s_base_transp_2mat(a,b) + import psb_s_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_s_base_transp_2mat + end interface + + interface + subroutine psb_s_base_transc_2mat(a,b) + import psb_s_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_s_base_transc_2mat + end interface + + interface + subroutine psb_s_base_transp_1mat(a) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + end subroutine psb_s_base_transp_1mat + end interface + + interface + subroutine psb_s_base_transc_1mat(a) + import psb_s_base_sparse_mat, psb_spk_ + class(psb_s_base_sparse_mat), intent(inout) :: a + end subroutine psb_s_base_transc_1mat + end interface + + + + + !================= + ! + ! COO interfaces + ! + !================= + + interface + subroutine psb_s_coo_reallocate_nz(nz,a) + import psb_s_coo_sparse_mat + integer, intent(in) :: nz + class(psb_s_coo_sparse_mat), intent(inout) :: a + end subroutine psb_s_coo_reallocate_nz + end interface + + interface + subroutine psb_s_coo_reinit(a,clear) + import psb_s_coo_sparse_mat + class(psb_s_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_s_coo_reinit + end interface + + interface + subroutine psb_s_coo_trim(a) + import psb_s_coo_sparse_mat + class(psb_s_coo_sparse_mat), intent(inout) :: a + end subroutine psb_s_coo_trim + end interface + + interface + subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) + import psb_s_coo_sparse_mat + integer, intent(in) :: m,n + class(psb_s_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_s_coo_allocate_mnnz + end interface + + interface + subroutine psb_s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_s_coo_sparse_mat + integer, intent(in) :: iout + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_s_coo_print + end interface + + + interface + function psb_s_coo_get_nz_row(idx,a) result(res) + import psb_s_coo_sparse_mat + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + end function psb_s_coo_get_nz_row + end interface + interface - subroutine s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod + subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + import psb_spk_ integer, intent(in) :: nzin,dupl integer, intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) integer, intent(out) :: nzout, info integer, intent(in), optional :: idir - end subroutine s_fix_coo_inner + end subroutine psb_s_fix_coo_inner end interface interface - subroutine s_fix_coo_impl(a,info,idir) - use psb_const_mod + subroutine psb_s_fix_coo(a,info,idir) import psb_s_coo_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a integer, intent(out) :: info integer, intent(in), optional :: idir - end subroutine s_fix_coo_impl + end subroutine psb_s_fix_coo end interface - + interface - subroutine s_cp_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_s_cp_coo_to_coo(a,b,info) import psb_s_coo_sparse_mat class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_cp_coo_to_coo_impl + end subroutine psb_s_cp_coo_to_coo end interface interface - subroutine s_cp_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_s_cp_coo_from_coo(a,b,info) import psb_s_coo_sparse_mat - class(psb_s_coo_sparse_mat), intent(out) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine s_cp_coo_from_coo_impl + end subroutine psb_s_cp_coo_from_coo end interface - + interface - subroutine s_cp_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_s_cp_coo_to_fmt(a,b,info) import psb_s_coo_sparse_mat, psb_s_base_sparse_mat class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_cp_coo_to_fmt_impl + end subroutine psb_s_cp_coo_to_fmt end interface - + interface - subroutine s_cp_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_s_cp_coo_from_fmt(a,b,info) import psb_s_coo_sparse_mat, psb_s_base_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine s_cp_coo_from_fmt_impl + end subroutine psb_s_cp_coo_from_fmt end interface - + interface - subroutine s_mv_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_s_mv_coo_to_coo(a,b,info) import psb_s_coo_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_coo_to_coo_impl + end subroutine psb_s_mv_coo_to_coo end interface - + interface - subroutine s_mv_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_s_mv_coo_from_coo(a,b,info) import psb_s_coo_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_coo_from_coo_impl + end subroutine psb_s_mv_coo_from_coo end interface - + interface - subroutine s_mv_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_s_mv_coo_to_fmt(a,b,info) import psb_s_coo_sparse_mat, psb_s_base_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_coo_to_fmt_impl + end subroutine psb_s_mv_coo_to_fmt end interface - + interface - subroutine s_mv_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_s_mv_coo_from_fmt(a,b,info) import psb_s_coo_sparse_mat, psb_s_base_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_coo_from_fmt_impl + end subroutine psb_s_mv_coo_from_fmt end interface - - + interface - subroutine s_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_s_coo_sparse_mat + subroutine psb_s_coo_cp_from(a,b) + import psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_coo_sparse_mat), intent(inout) :: a + type(psb_s_coo_sparse_mat), intent(in) :: b + end subroutine psb_s_coo_cp_from + end interface + + interface + subroutine psb_s_coo_mv_from(a,b) + import psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_coo_sparse_mat), intent(inout) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: b + end subroutine psb_s_coo_mv_from + end interface + + + interface + subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer, intent(in) :: nz,ia(:), ja(:),& & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine s_coo_csput_impl + end subroutine psb_s_coo_csput end interface - + interface - subroutine s_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_s_coo_sparse_mat - implicit none + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -241,16 +569,13 @@ module psb_s_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine s_coo_csgetptn_impl + end subroutine psb_s_coo_csgetptn end interface interface - subroutine s_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_s_coo_sparse_mat - implicit none - + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -261,1146 +586,117 @@ module psb_s_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine s_coo_csgetrow_impl + end subroutine psb_s_coo_csgetrow end interface - interface s_coo_cssm_impl - subroutine s_coo_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_coo_sparse_mat + interface + subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_coo_cssv_impl - subroutine s_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_coo_sparse_mat + end subroutine psb_s_coo_cssv + subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_coo_cssm_impl + end subroutine psb_s_coo_cssm end interface - - interface s_coo_csmm_impl - subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_coo_sparse_mat + + interface + subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_coo_csmv_impl - subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_coo_sparse_mat + end subroutine psb_s_coo_csmv + subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_coo_csmm_impl + end subroutine psb_s_coo_csmm end interface - - - interface s_coo_csnmi_impl - function s_coo_csnmi_impl(a) result(res) - use psb_const_mod - import psb_s_coo_sparse_mat + + + interface + function psb_s_coo_csnmi(a) result(res) + import psb_s_coo_sparse_mat, psb_spk_ class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res - end function s_coo_csnmi_impl + end function psb_s_coo_csnmi end interface - - + + interface + subroutine psb_s_coo_get_diag(a,d,info) + import psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_coo_get_diag + end interface + + interface + subroutine psb_s_coo_scal(d,a,info) + import psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_coo_scal + end interface + + interface + subroutine psb_s_coo_scals(d,a,info) + import psb_s_coo_sparse_mat, psb_spk_ + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_s_coo_scals + end interface + + contains - - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - subroutine cp_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_coo - - subroutine cp_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_coo - - - subroutine cp_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_fmt - - subroutine cp_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_fmt - - - subroutine mv_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_coo - - subroutine mv_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_coo - - - subroutine mv_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_fmt - - subroutine mv_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_fmt - + + subroutine s_base_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_base_sparse_mat), intent(out) :: a - type(psb_s_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine s_base_mv_from - - subroutine s_base_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_base_sparse_mat), intent(out) :: a - type(psb_s_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine s_base_cp_from - - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine csput - - subroutine s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_base_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_csgetrow - - - - subroutine s_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: appens_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - appens_ = append - else - appens_ = .false. - endif - if (appens_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=appens_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csgetblk - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csclip - - subroutine s_coo_transp_1mat(a) - use psb_error_mod implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - - integer, allocatable :: itemp(:) - integer :: info - - call a%psb_s_base_sparse_mat%psb_base_sparse_mat%transp() - call move_alloc(a%ia,itemp) - call move_alloc(a%ja,a%ia) - call move_alloc(itemp,a%ja) - - call a%fix(info) - - return - - end subroutine s_coo_transp_1mat - - subroutine s_coo_transc_1mat(a) - use psb_error_mod - implicit none - - class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(out) :: a + type(psb_s_base_sparse_mat), intent(inout) :: b - call a%transp() - end subroutine s_coo_transc_1mat - - subroutine s_base_transp_2mat(a,b) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - type(psb_s_coo_sparse_mat) :: tmp - integer err_act, info - character(len=*), parameter :: name='s_base_transp' + ! No new things here, very easy + call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - call psb_erractionsave(err_act) - - info = 0 - select type(b) - class is (psb_s_base_sparse_mat) - call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - class default - info = 700 - end select - if (info /= 0) then - call psb_errpush(info,name,a_err=b%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - end subroutine s_base_transp_2mat - - subroutine s_base_transc_2mat(a,b) - use psb_error_mod + end subroutine s_base_mv_from + + subroutine s_base_cp_from(a,b) implicit none class(psb_s_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - call a%transp(b) - end subroutine s_base_transc_2mat - - subroutine s_base_transp_1mat(a) - use psb_error_mod - implicit none - - class(psb_s_base_sparse_mat), intent(inout) :: a - - type(psb_s_coo_sparse_mat) :: tmp - integer :: err_act, info - character(len=*), parameter :: name='s_base_transp' - - call psb_erractionsave(err_act) - info = 0 - call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - - if (info /= 0) then - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - - - end subroutine s_base_transp_1mat - - subroutine s_base_transc_1mat(a) - use psb_error_mod - implicit none - - class(psb_s_base_sparse_mat), intent(inout) :: a - - call a%transp() - end subroutine s_base_transc_1mat - - - - - !==================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !==================================== - - subroutine s_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='s_base_csmm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_base_csmm - - subroutine s_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='s_base_csmv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine s_base_csmv - - subroutine s_base_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='s_base_cssm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_base_cssm - - subroutine s_base_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='s_base_cssv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_base_cssv - - subroutine s_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - - real(psb_spk_), allocatable :: tmp(:,:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='s_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(sone,x,szero,tmp,info,trans) - - if (info == 0)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == 0)& - & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine s_cssm - - subroutine s_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - - real(psb_spk_), allocatable :: tmp(:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='s_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) tmp(1:nac) = d(1:nac)*x(1:nac) - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(sone,x,szero,tmp,info,trans) - - if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar) - if (info == 0)& - & call psb_geaxpby(nar,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine s_cssv - - - subroutine s_scals(d,a,info) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='s_scals' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_scals - - - subroutine s_scal(d,a,info) - use psb_error_mod - implicit none - class(psb_s_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='s_scal' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_scal - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = -sone - - return - - end function csnmi - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - + type(psb_s_base_sparse_mat), intent(in) :: b + + ! No new things here, very easy + call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) + return - - end subroutine get_diag - - - - + + end subroutine s_base_cp_from + + + !==================================== ! ! @@ -1412,8 +708,8 @@ contains ! ! !==================================== - - + + function s_coo_sizeof(a) result(res) implicit none @@ -1423,24 +719,24 @@ contains res = res + psb_sizeof_sp * size(a%val) res = res + psb_sizeof_int * size(a%ia) res = res + psb_sizeof_int * size(a%ja) - + end function s_coo_sizeof - - + + function s_coo_get_fmt(a) result(res) implicit none class(psb_s_coo_sparse_mat), intent(in) :: a character(len=5) :: res res = 'COO' end function s_coo_get_fmt - - + + function s_coo_get_size(a) result(res) implicit none class(psb_s_coo_sparse_mat), intent(in) :: a integer :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) if (allocated(a%ja)) then if (res >= 0) then @@ -1457,66 +753,16 @@ contains end if end if end function s_coo_get_size - - + + function s_coo_get_nzeros(a) result(res) implicit none class(psb_s_coo_sparse_mat), intent(in) :: a integer :: res res = a%nnz end function s_coo_get_nzeros - - - function s_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - implicit none - - class(psb_s_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer :: res - integer :: nzin_, nza,ip,jp,i,k - - res = 0 - nza = a%get_nzeros() - if (a%is_sorted()) then - ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - - end function s_coo_get_nz_row - + + !==================================== ! ! @@ -1529,807 +775,49 @@ contains ! ! !==================================== - - subroutine s_coo_set_nzeros(nz,a) - implicit none - integer, intent(in) :: nz - class(psb_s_coo_sparse_mat), intent(inout) :: a - - a%nnz = nz - - end subroutine s_coo_set_nzeros - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - - subroutine s_fix_coo(a,info,idir) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: idir - Integer :: err_act - character(len=20) :: name='fix_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_fix_coo_impl(a,info,idir) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine s_fix_coo - - - subroutine s_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_coo_to_coo - - subroutine s_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(out) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_coo_from_coo - - - subroutine s_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_coo_to_fmt - - subroutine s_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_coo_from_fmt - - - - subroutine s_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_coo_to_coo - - subroutine s_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_coo_from_coo - - - - subroutine s_coo_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_coo_sparse_mat), intent(out) :: a - type(psb_s_coo_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_coo_cp_from - - subroutine s_coo_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_coo_sparse_mat), intent(out) :: a - type(psb_s_coo_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_coo_mv_from - - - subroutine s_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_coo_to_fmt - - subroutine s_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_coo_from_fmt - - - - subroutine s_coo_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_s_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='s_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,a%ja,a%val,info) - - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_reallocate_nz - - - subroutine s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='s_coo_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - nza = a%get_nzeros() - call s_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_csput - - - subroutine s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + + subroutine s_coo_set_nzeros(nz,a) + implicit none + integer, intent(in) :: nz + class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call s_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_csgetrow - - - subroutine s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + a%nnz = nz - class(psb_s_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call s_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_csgetptn - - + end subroutine s_coo_set_nzeros + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + + subroutine s_coo_free(a) implicit none - + class(psb_s_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() call a%set_nrows(0) call a%set_ncols(0) - + call a%set_nzeros(0) + return - + end subroutine s_coo_free - - subroutine s_coo_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_s_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = szero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_reinit - - - subroutine s_coo_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_trim - - subroutine s_coo_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_s_coo_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(0) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - end if - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_allocate_mnnz - - - subroutine s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_s_coo_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='s_coo_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - - end subroutine s_coo_print - - - - + + + !==================================== ! ! @@ -2342,380 +830,33 @@ contains ! ! !==================================== - - subroutine s_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod + subroutine s_coo_transp_1mat(a) implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nac, nar - real(psb_spk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='s_coo_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - call s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_csmv - - subroutine s_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - real(psb_spk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + class(psb_s_coo_sparse_mat), intent(inout) :: a - call s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_csmm - - - subroutine s_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nar, nac - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_coo_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + integer, allocatable :: itemp(:) + integer :: info - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call s_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine s_coo_cssv - - - - subroutine s_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + call a%psb_s_base_sparse_mat%psb_base_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%fix(info) - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call s_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_cssm - - function s_coo_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = s_coo_csnmi_impl(a) - - return - - end function s_coo_csnmi - - subroutine s_coo_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = szero - - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_coo_get_diag - - subroutine s_coo_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine s_coo_scal - - subroutine s_coo_scals(d,a,info) - use psb_error_mod - use psb_const_mod + + end subroutine s_coo_transp_1mat + + subroutine s_coo_transc_1mat(a) implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + + call a%transp() + end subroutine s_coo_transc_1mat - end subroutine s_coo_scals end module psb_s_base_mat_mod diff --git a/base/modules/psb_s_csc_mat_mod.f03 b/base/modules/psb_s_csc_mat_mod.f03 index b93fee62..0c9064dd 100644 --- a/base/modules/psb_s_csc_mat_mod.f03 +++ b/base/modules/psb_s_csc_mat_mod.f03 @@ -8,161 +8,195 @@ module psb_s_csc_mat_mod real(psb_spk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => s_csc_get_nzeros - procedure, pass(a) :: get_fmt => s_csc_get_fmt - procedure, pass(a) :: get_diag => s_csc_get_diag - procedure, pass(a) :: s_base_csmm => s_csc_csmm - procedure, pass(a) :: s_base_csmv => s_csc_csmv - procedure, pass(a) :: s_base_cssm => s_csc_cssm - procedure, pass(a) :: s_base_cssv => s_csc_cssv - procedure, pass(a) :: s_scals => s_csc_scals - procedure, pass(a) :: s_scal => s_csc_scal - procedure, pass(a) :: csnmi => s_csc_csnmi - procedure, pass(a) :: reallocate_nz => s_csc_reallocate_nz - procedure, pass(a) :: csput => s_csc_csput - procedure, pass(a) :: allocate_mnnz => s_csc_allocate_mnnz - procedure, pass(a) :: cp_to_coo => s_cp_csc_to_coo - procedure, pass(a) :: cp_from_coo => s_cp_csc_from_coo - procedure, pass(a) :: cp_to_fmt => s_cp_csc_to_fmt - procedure, pass(a) :: cp_from_fmt => s_cp_csc_from_fmt - procedure, pass(a) :: mv_to_coo => s_mv_csc_to_coo - procedure, pass(a) :: mv_from_coo => s_mv_csc_from_coo - procedure, pass(a) :: mv_to_fmt => s_mv_csc_to_fmt - procedure, pass(a) :: mv_from_fmt => s_mv_csc_from_fmt - procedure, pass(a) :: csgetptn => s_csc_csgetptn - procedure, pass(a) :: s_csgetrow => s_csc_csgetrow - procedure, pass(a) :: get_size => s_csc_get_size - procedure, pass(a) :: free => s_csc_free - procedure, pass(a) :: trim => s_csc_trim - procedure, pass(a) :: print => s_csc_print - procedure, pass(a) :: sizeof => s_csc_sizeof - procedure, pass(a) :: reinit => s_csc_reinit - procedure, pass(a) :: s_csc_cp_from - generic, public :: cp_from => s_csc_cp_from - procedure, pass(a) :: s_csc_mv_from - generic, public :: mv_from => s_csc_mv_from - end type psb_s_csc_sparse_mat + procedure, pass(a) :: get_size => s_csc_get_size + procedure, pass(a) :: get_nzeros => s_csc_get_nzeros + procedure, pass(a) :: get_fmt => s_csc_get_fmt + procedure, pass(a) :: sizeof => s_csc_sizeof + procedure, pass(a) :: s_csmm => psb_s_csc_csmm + procedure, pass(a) :: s_csmv => psb_s_csc_csmv + procedure, pass(a) :: s_inner_cssm => psb_s_csc_cssm + procedure, pass(a) :: s_inner_cssv => psb_s_csc_cssv + procedure, pass(a) :: s_scals => psb_s_csc_scals + procedure, pass(a) :: s_scal => psb_s_csc_scal + procedure, pass(a) :: csnmi => psb_s_csc_csnmi + procedure, pass(a) :: reallocate_nz => psb_s_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_s_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_s_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_s_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_s_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_s_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_s_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_s_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_s_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_s_mv_csc_from_fmt + procedure, pass(a) :: csput => psb_s_csc_csput + procedure, pass(a) :: get_diag => psb_s_csc_get_diag + procedure, pass(a) :: csgetptn => psb_s_csc_csgetptn + procedure, pass(a) :: s_csgetrow => psb_s_csc_csgetrow + procedure, pass(a) :: get_nz_col => s_csc_get_nz_col + procedure, pass(a) :: reinit => psb_s_csc_reinit + procedure, pass(a) :: trim => psb_s_csc_trim + procedure, pass(a) :: print => psb_s_csc_print + procedure, pass(a) :: free => s_csc_free + procedure, pass(a) :: psb_s_csc_cp_from + generic, public :: cp_from => psb_s_csc_cp_from + procedure, pass(a) :: psb_s_csc_mv_from + generic, public :: mv_from => psb_s_csc_mv_from - private :: s_csc_get_nzeros, s_csc_csmm, s_csc_csmv, s_csc_cssm, s_csc_cssv, & - & s_csc_csput, s_csc_reallocate_nz, s_csc_allocate_mnnz, & - & s_csc_free, s_csc_print, s_csc_get_fmt, s_csc_csnmi, get_diag, & - & s_cp_csc_to_coo, s_cp_csc_from_coo, & - & s_mv_csc_to_coo, s_mv_csc_from_coo, & - & s_cp_csc_to_fmt, s_cp_csc_from_fmt, & - & s_mv_csc_to_fmt, s_mv_csc_from_fmt, & - & s_csc_scals, s_csc_scal, s_csc_trim, s_csc_csgetrow, s_csc_get_size, & - & s_csc_sizeof, s_csc_csgetptn, s_csc_get_nz_row, s_csc_reinit + end type psb_s_csc_sparse_mat + private :: s_csc_get_nzeros, s_csc_free, s_csc_get_fmt, & + & s_csc_get_size, s_csc_sizeof, s_csc_get_nz_col - interface - subroutine s_cp_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod + interface + subroutine psb_s_csc_reallocate_nz(nz,a) import psb_s_csc_sparse_mat - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine s_cp_csc_to_fmt_impl + integer, intent(in) :: nz + class(psb_s_csc_sparse_mat), intent(inout) :: a + end subroutine psb_s_csc_reallocate_nz end interface - + interface - subroutine s_cp_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod + subroutine psb_s_csc_reinit(a,clear) + import psb_s_csc_sparse_mat + class(psb_s_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_s_csc_reinit + end interface + + interface + subroutine psb_s_csc_trim(a) import psb_s_csc_sparse_mat class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine s_cp_csc_from_fmt_impl + end subroutine psb_s_csc_trim end interface - - - interface - subroutine s_cp_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod + + interface + subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) import psb_s_csc_sparse_mat + integer, intent(in) :: m,n + class(psb_s_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_s_csc_allocate_mnnz + end interface + + interface + subroutine psb_s_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_s_csc_sparse_mat + integer, intent(in) :: iout + class(psb_s_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_s_csc_print + end interface + + interface + subroutine psb_s_cp_csc_to_coo(a,b,info) + import psb_s_coo_sparse_mat, psb_s_csc_sparse_mat class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_cp_csc_to_coo_impl + end subroutine psb_s_cp_csc_to_coo end interface - + interface - subroutine s_cp_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csc_sparse_mat + subroutine psb_s_cp_csc_from_coo(a,b,info) + import psb_s_csc_sparse_mat, psb_s_coo_sparse_mat class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine s_cp_csc_from_coo_impl + end subroutine psb_s_cp_csc_from_coo end interface - + interface - subroutine s_mv_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csc_sparse_mat + subroutine psb_s_cp_csc_to_fmt(a,b,info) + import psb_s_csc_sparse_mat, psb_s_base_sparse_mat + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_cp_csc_to_fmt + end interface + + interface + subroutine psb_s_cp_csc_from_fmt(a,b,info) + import psb_s_csc_sparse_mat, psb_s_base_sparse_mat + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_s_cp_csc_from_fmt + end interface + + interface + subroutine psb_s_mv_csc_to_coo(a,b,info) + import psb_s_csc_sparse_mat, psb_s_coo_sparse_mat class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_csc_to_fmt_impl + end subroutine psb_s_mv_csc_to_coo end interface - + interface - subroutine s_mv_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csc_sparse_mat + subroutine psb_s_mv_csc_from_coo(a,b,info) + import psb_s_csc_sparse_mat, psb_s_coo_sparse_mat + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_mv_csc_from_coo + end interface + + interface + subroutine psb_s_mv_csc_to_fmt(a,b,info) + import psb_s_csc_sparse_mat, psb_s_base_sparse_mat + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_mv_csc_to_fmt + end interface + + interface + subroutine psb_s_mv_csc_from_fmt(a,b,info) + import psb_s_csc_sparse_mat, psb_s_base_sparse_mat class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_csc_from_fmt_impl + end subroutine psb_s_mv_csc_from_fmt end interface - - + interface - subroutine s_mv_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csc_sparse_mat + subroutine psb_s_csc_cp_from(a,b) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine s_mv_csc_to_coo_impl + type(psb_s_csc_sparse_mat), intent(in) :: b + end subroutine psb_s_csc_cp_from end interface - + interface - subroutine s_mv_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csc_sparse_mat - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine s_mv_csc_from_coo_impl + subroutine psb_s_csc_mv_from(a,b) + import psb_s_csc_sparse_mat, psb_spk_ + class(psb_s_csc_sparse_mat), intent(inout) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: b + end subroutine psb_s_csc_mv_from end interface - + + interface - subroutine s_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_s_csc_sparse_mat + subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine s_csc_csput_impl + end subroutine psb_s_csc_csput end interface - + interface - subroutine s_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_s_csc_sparse_mat - implicit none - + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -172,16 +206,13 @@ module psb_s_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine s_csc_csgetptn_impl + end subroutine psb_s_csc_csgetptn end interface - + interface - subroutine s_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_s_csc_sparse_mat - implicit none - + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -192,61 +223,98 @@ module psb_s_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine s_csc_csgetrow_impl + end subroutine psb_s_csc_csgetrow end interface - interface s_csc_cssm_impl - subroutine s_csc_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csc_sparse_mat + interface + subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_s_csc_sparse_mat, psb_spk_, psb_s_coo_sparse_mat + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csc_csgetblk + end interface + + interface + subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csc_cssv_impl - subroutine s_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csc_sparse_mat + end subroutine psb_s_csc_cssv + subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csc_cssm_impl + end subroutine psb_s_csc_cssm end interface - - interface s_csc_csmm_impl - subroutine s_csc_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csc_sparse_mat + + interface + subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csc_csmv_impl - subroutine s_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csc_sparse_mat + end subroutine psb_s_csc_csmv + subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csc_csmm_impl + end subroutine psb_s_csc_csmm end interface - - interface s_csc_csnmi_impl - function s_csc_csnmi_impl(a) result(res) - use psb_const_mod - import psb_s_csc_sparse_mat + + + interface + function psb_s_csc_csnmi(a) result(res) + import psb_s_csc_sparse_mat, psb_spk_ class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res - end function s_csc_csnmi_impl + end function psb_s_csc_csnmi + end interface + + interface + subroutine psb_s_csc_get_diag(a,d,info) + import psb_s_csc_sparse_mat, psb_spk_ + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_csc_get_diag + end interface + + interface + subroutine psb_s_csc_scal(d,a,info) + import psb_s_csc_sparse_mat, psb_spk_ + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_csc_scal + end interface + + interface + subroutine psb_s_csc_scals(d,a,info) + import psb_s_csc_sparse_mat, psb_spk_ + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_s_csc_scals end interface - contains @@ -345,339 +413,6 @@ contains !===================================== - subroutine s_csc_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_s_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='s_csc_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_reallocate_nz - - subroutine s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='s_csc_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call s_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_csc_csput - - subroutine s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call s_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_csgetptn - - - subroutine s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call s_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_csgetrow - - - subroutine s_csc_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_csgetblk - - - subroutine s_csc_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_csclip - - subroutine s_csc_free(a) implicit none @@ -694,903 +429,4 @@ contains end subroutine s_csc_free - subroutine s_csc_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = szero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_reinit - - subroutine s_csc_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, n - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - n = a%get_ncols() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_trim - - subroutine s_cp_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csc_to_coo - - subroutine s_cp_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csc_from_coo - - - subroutine s_cp_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csc_to_fmt - - subroutine s_cp_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csc_from_fmt - - - subroutine s_mv_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csc_to_coo - - subroutine s_mv_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csc_from_coo - - - subroutine s_mv_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csc_to_fmt - - subroutine s_mv_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csc_from_fmt - - subroutine s_csc_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_s_csc_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%icp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_allocate_mnnz - - - subroutine s_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_s_csc_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='s_csc_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),(i),a%val(j) - end do - enddo - endif - endif - - end subroutine s_csc_print - - - subroutine s_csc_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(out) :: a - type(psb_s_csc_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) - a%icp = b%icp - a%ia = b%ia - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_csc_cp_from - - subroutine s_csc_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_csc_sparse_mat), intent(out) :: a - type(psb_s_csc_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_csc_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine s_csc_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csc_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call s_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_csmv - - subroutine s_csc_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call s_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_csmm - - - subroutine s_csc_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csc_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call s_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine s_csc_cssv - - - - subroutine s_csc_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call s_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_cssm - - function s_csc_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = s_csc_csnmi_impl(a) - - return - - end function s_csc_csnmi - - subroutine s_csc_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = szero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_get_diag - - - subroutine s_csc_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, n - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - n = a%get_ncols() - if (size(d) < n) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, n - do j = a%icp(i), a%icp(i+1) -1 - a%val(j) = a%val(j) * d(a%ia(j)) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_scal - - - subroutine s_csc_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csc_scals - - - end module psb_s_csc_mat_mod diff --git a/base/modules/psb_s_csr_mat_mod.f03 b/base/modules/psb_s_csr_mat_mod.f03 index 18d56d69..529beb33 100644 --- a/base/modules/psb_s_csr_mat_mod.f03 +++ b/base/modules/psb_s_csr_mat_mod.f03 @@ -8,165 +8,195 @@ module psb_s_csr_mat_mod real(psb_spk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => s_csr_get_nzeros - procedure, pass(a) :: get_fmt => s_csr_get_fmt - procedure, pass(a) :: get_diag => s_csr_get_diag - procedure, pass(a) :: s_base_csmm => s_csr_csmm - procedure, pass(a) :: s_base_csmv => s_csr_csmv - procedure, pass(a) :: s_base_cssm => s_csr_cssm - procedure, pass(a) :: s_base_cssv => s_csr_cssv - procedure, pass(a) :: s_scals => s_csr_scals - procedure, pass(a) :: s_scal => s_csr_scal - procedure, pass(a) :: csnmi => s_csr_csnmi - procedure, pass(a) :: reallocate_nz => s_csr_reallocate_nz - procedure, pass(a) :: csput => s_csr_csput - procedure, pass(a) :: allocate_mnnz => s_csr_allocate_mnnz - procedure, pass(a) :: cp_to_coo => s_cp_csr_to_coo - procedure, pass(a) :: cp_from_coo => s_cp_csr_from_coo - procedure, pass(a) :: cp_to_fmt => s_cp_csr_to_fmt - procedure, pass(a) :: cp_from_fmt => s_cp_csr_from_fmt - procedure, pass(a) :: mv_to_coo => s_mv_csr_to_coo - procedure, pass(a) :: mv_from_coo => s_mv_csr_from_coo - procedure, pass(a) :: mv_to_fmt => s_mv_csr_to_fmt - procedure, pass(a) :: mv_from_fmt => s_mv_csr_from_fmt - procedure, pass(a) :: csgetptn => s_csr_csgetptn - procedure, pass(a) :: s_csgetrow => s_csr_csgetrow - procedure, pass(a) :: get_nz_row => s_csr_get_nz_row - procedure, pass(a) :: get_size => s_csr_get_size - procedure, pass(a) :: free => s_csr_free - procedure, pass(a) :: trim => s_csr_trim - procedure, pass(a) :: print => s_csr_print - procedure, pass(a) :: sizeof => s_csr_sizeof - procedure, pass(a) :: reinit => s_csr_reinit - procedure, pass(a) :: s_csr_cp_from - generic, public :: cp_from => s_csr_cp_from - procedure, pass(a) :: s_csr_mv_from - generic, public :: mv_from => s_csr_mv_from + procedure, pass(a) :: get_size => s_csr_get_size + procedure, pass(a) :: get_nzeros => s_csr_get_nzeros + procedure, pass(a) :: get_fmt => s_csr_get_fmt + procedure, pass(a) :: sizeof => s_csr_sizeof + procedure, pass(a) :: s_csmm => psb_s_csr_csmm + procedure, pass(a) :: s_csmv => psb_s_csr_csmv + procedure, pass(a) :: s_inner_cssm => psb_s_csr_cssm + procedure, pass(a) :: s_inner_cssv => psb_s_csr_cssv + procedure, pass(a) :: s_scals => psb_s_csr_scals + procedure, pass(a) :: s_scal => psb_s_csr_scal + procedure, pass(a) :: csnmi => psb_s_csr_csnmi + procedure, pass(a) :: reallocate_nz => psb_s_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_s_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_s_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_s_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_s_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_s_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_s_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_s_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_s_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_s_mv_csr_from_fmt + procedure, pass(a) :: csput => psb_s_csr_csput + procedure, pass(a) :: get_diag => psb_s_csr_get_diag + procedure, pass(a) :: csgetptn => psb_s_csr_csgetptn + procedure, pass(a) :: s_csgetrow => psb_s_csr_csgetrow + procedure, pass(a) :: get_nz_row => s_csr_get_nz_row + procedure, pass(a) :: reinit => psb_s_csr_reinit + procedure, pass(a) :: trim => psb_s_csr_trim + procedure, pass(a) :: print => psb_s_csr_print + procedure, pass(a) :: free => s_csr_free + procedure, pass(a) :: psb_s_csr_cp_from + generic, public :: cp_from => psb_s_csr_cp_from + procedure, pass(a) :: psb_s_csr_mv_from + generic, public :: mv_from => psb_s_csr_mv_from end type psb_s_csr_sparse_mat - private :: s_csr_get_nzeros, s_csr_csmm, s_csr_csmv, s_csr_cssm, s_csr_cssv, & - & s_csr_csput, s_csr_reallocate_nz, s_csr_allocate_mnnz, & - & s_csr_free, s_csr_print, s_csr_get_fmt, s_csr_csnmi, get_diag, & - & s_cp_csr_to_coo, s_cp_csr_from_coo, & - & s_mv_csr_to_coo, s_mv_csr_from_coo, & - & s_cp_csr_to_fmt, s_cp_csr_from_fmt, & - & s_mv_csr_to_fmt, s_mv_csr_from_fmt, & - & s_csr_scals, s_csr_scal, s_csr_trim, s_csr_csgetrow, s_csr_get_size, & - & s_csr_sizeof, s_csr_csgetptn, s_csr_get_nz_row, s_csr_reinit -!!$, & -!!$ & s_csr_mv_from, s_csr_mv_from + private :: s_csr_get_nzeros, s_csr_free, s_csr_get_fmt, & + & s_csr_get_size, s_csr_sizeof, s_csr_get_nz_row - - interface - subroutine s_cp_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod + interface + subroutine psb_s_csr_reallocate_nz(nz,a) import psb_s_csr_sparse_mat - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine s_cp_csr_to_fmt_impl + integer, intent(in) :: nz + class(psb_s_csr_sparse_mat), intent(inout) :: a + end subroutine psb_s_csr_reallocate_nz end interface - + interface - subroutine s_cp_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod + subroutine psb_s_csr_reinit(a,clear) + import psb_s_csr_sparse_mat + class(psb_s_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_s_csr_reinit + end interface + + interface + subroutine psb_s_csr_trim(a) import psb_s_csr_sparse_mat class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine s_cp_csr_from_fmt_impl + end subroutine psb_s_csr_trim end interface - - - interface - subroutine s_cp_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod + + interface + subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) + import psb_s_csr_sparse_mat + integer, intent(in) :: m,n + class(psb_s_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_s_csr_allocate_mnnz + end interface + + interface + subroutine psb_s_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) import psb_s_csr_sparse_mat + integer, intent(in) :: iout + class(psb_s_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_s_csr_print + end interface + + interface + subroutine psb_s_cp_csr_to_coo(a,b,info) + import psb_s_coo_sparse_mat, psb_s_csr_sparse_mat class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_cp_csr_to_coo_impl + end subroutine psb_s_cp_csr_to_coo end interface - + interface - subroutine s_cp_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csr_sparse_mat + subroutine psb_s_cp_csr_from_coo(a,b,info) + import psb_s_csr_sparse_mat, psb_s_coo_sparse_mat class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine s_cp_csr_from_coo_impl + end subroutine psb_s_cp_csr_from_coo end interface - + interface - subroutine s_mv_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csr_sparse_mat + subroutine psb_s_cp_csr_to_fmt(a,b,info) + import psb_s_csr_sparse_mat, psb_s_base_sparse_mat + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_cp_csr_to_fmt + end interface + + interface + subroutine psb_s_cp_csr_from_fmt(a,b,info) + import psb_s_csr_sparse_mat, psb_s_base_sparse_mat + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_s_cp_csr_from_fmt + end interface + + interface + subroutine psb_s_mv_csr_to_coo(a,b,info) + import psb_s_csr_sparse_mat, psb_s_coo_sparse_mat class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_csr_to_fmt_impl + end subroutine psb_s_mv_csr_to_coo end interface - + interface - subroutine s_mv_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csr_sparse_mat + subroutine psb_s_mv_csr_from_coo(a,b,info) + import psb_s_csr_sparse_mat, psb_s_coo_sparse_mat + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_mv_csr_from_coo + end interface + + interface + subroutine psb_s_mv_csr_to_fmt(a,b,info) + import psb_s_csr_sparse_mat, psb_s_base_sparse_mat + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_s_mv_csr_to_fmt + end interface + + interface + subroutine psb_s_mv_csr_from_fmt(a,b,info) + import psb_s_csr_sparse_mat, psb_s_base_sparse_mat class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine s_mv_csr_from_fmt_impl + end subroutine psb_s_mv_csr_from_fmt end interface - - + interface - subroutine s_mv_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csr_sparse_mat + subroutine psb_s_csr_cp_from(a,b) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine s_mv_csr_to_coo_impl + type(psb_s_csr_sparse_mat), intent(in) :: b + end subroutine psb_s_csr_cp_from end interface - + interface - subroutine s_mv_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_s_base_mat_mod - import psb_s_csr_sparse_mat - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine s_mv_csr_from_coo_impl + subroutine psb_s_csr_mv_from(a,b) + import psb_s_csr_sparse_mat, psb_spk_ + class(psb_s_csr_sparse_mat), intent(inout) :: a + type(psb_s_csr_sparse_mat), intent(inout) :: b + end subroutine psb_s_csr_mv_from end interface - + + interface - subroutine s_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_s_csr_sparse_mat + subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine s_csr_csput_impl + end subroutine psb_s_csr_csput end interface - + interface - subroutine s_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_s_csr_sparse_mat - implicit none - + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -176,16 +206,13 @@ module psb_s_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine s_csr_csgetptn_impl + end subroutine psb_s_csr_csgetptn end interface - + interface - subroutine s_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_s_csr_sparse_mat - implicit none - + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -196,58 +223,96 @@ module psb_s_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine s_csr_csgetrow_impl + end subroutine psb_s_csr_csgetrow end interface - interface s_csr_cssm_impl - subroutine s_csr_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csr_sparse_mat + interface + subroutine psb_s_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_s_csr_sparse_mat, psb_spk_, psb_s_coo_sparse_mat + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csr_csgetblk + end interface + + interface + subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csr_cssv_impl - subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csr_sparse_mat + end subroutine psb_s_csr_cssv + subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csr_cssm_impl + end subroutine psb_s_csr_cssm end interface - - interface s_csr_csmm_impl - subroutine s_csr_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csr_sparse_mat + + interface + subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csr_csmv_impl - subroutine s_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_s_csr_sparse_mat + end subroutine psb_s_csr_csmv + subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine s_csr_csmm_impl + end subroutine psb_s_csr_csmm end interface - - interface s_csr_csnmi_impl - function s_csr_csnmi_impl(a) result(res) - use psb_const_mod - import psb_s_csr_sparse_mat + + + interface + function psb_s_csr_csnmi(a) result(res) + import psb_s_csr_sparse_mat, psb_spk_ class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - end function s_csr_csnmi_impl + end function psb_s_csr_csnmi + end interface + + interface + subroutine psb_s_csr_get_diag(a,d,info) + import psb_s_csr_sparse_mat, psb_spk_ + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_csr_get_diag + end interface + + interface + subroutine psb_s_csr_scal(d,a,info) + import psb_s_csr_sparse_mat, psb_spk_ + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_csr_scal + end interface + + interface + subroutine psb_s_csr_scals(d,a,info) + import psb_s_csr_sparse_mat, psb_spk_ + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_s_csr_scals end interface @@ -319,7 +384,7 @@ contains function s_csr_get_nz_row(idx,a) result(res) - use psb_const_mod + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a @@ -348,341 +413,6 @@ contains ! !===================================== - - subroutine s_csr_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_s_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='s_csr_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& - & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_reallocate_nz - - subroutine s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='s_csr_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call s_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_csr_csput - - subroutine s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call s_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_csgetptn - - - subroutine s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call s_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_csgetrow - - - subroutine s_csr_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: appens_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - appens_ = append - else - appens_ = .false. - endif - if (appens_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=appens_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_csgetblk - - - subroutine s_csr_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_csclip - - subroutine s_csr_free(a) implicit none @@ -699,906 +429,5 @@ contains end subroutine s_csr_free - subroutine s_csr_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = szero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_reinit - - - subroutine s_csr_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, m - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - m = a%get_nrows() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_trim - - - subroutine s_cp_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csr_to_coo - - subroutine s_cp_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csr_from_coo - - - subroutine s_cp_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csr_to_fmt - - subroutine s_cp_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_cp_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_cp_csr_from_fmt - - - subroutine s_mv_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csr_to_coo - - subroutine s_mv_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csr_from_coo - - - subroutine s_mv_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csr_to_fmt - - subroutine s_mv_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call s_mv_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_mv_csr_from_fmt - - - subroutine s_csr_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_s_csr_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%irp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_allocate_mnnz - - - subroutine s_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_s_csr_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='s_csr_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),(a%ja(j)),a%val(j) - end do - enddo - endif - endif - - end subroutine s_csr_print - - - subroutine s_csr_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(out) :: a - type(psb_s_csr_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) - a%irp = b%irp - a%ja = b%ja - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_csr_cp_from - - subroutine s_csr_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_s_csr_sparse_mat), intent(out) :: a - type(psb_s_csr_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine s_csr_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine s_csr_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csr_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call s_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_csmv - - subroutine s_csr_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call s_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_csmm - - - subroutine s_csr_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csr_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine s_csr_cssv - - - - subroutine s_csr_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='s_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_cssm - - function s_csr_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = s_csr_csnmi_impl(a) - - return - - end function s_csr_csnmi - - subroutine s_csr_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = szero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_get_diag - - - subroutine s_csr_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 - a%val(j) = a%val(j) * d(i) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_scal - - - subroutine s_csr_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csr_scals - - end module psb_s_csr_mat_mod diff --git a/base/modules/psb_s_mat_mod.f03 b/base/modules/psb_s_mat_mod.f03 index 4872f499..e70c43c3 100644 --- a/base/modules/psb_s_mat_mod.f03 +++ b/base/modules/psb_s_mat_mod.f03 @@ -9,20 +9,6 @@ module psb_s_mat_mod class(psb_s_base_sparse_mat), allocatable :: a contains - ! Setters - procedure, pass(a) :: set_nrows - procedure, pass(a) :: set_ncols - procedure, pass(a) :: set_dupl - procedure, pass(a) :: set_state - procedure, pass(a) :: set_null - procedure, pass(a) :: set_bld - procedure, pass(a) :: set_upd - procedure, pass(a) :: set_asb - procedure, pass(a) :: set_sorted - procedure, pass(a) :: set_upper - procedure, pass(a) :: set_lower - procedure, pass(a) :: set_triangle - procedure, pass(a) :: set_unit ! Getters procedure, pass(a) :: get_nrows procedure, pass(a) :: get_ncols @@ -40,106 +26,574 @@ module psb_s_mat_mod procedure, pass(a) :: is_lower procedure, pass(a) :: is_triangle procedure, pass(a) :: is_unit - procedure, pass(a) :: get_fmt => sparse_get_fmt - procedure, pass(a) :: sizeof => s_sizeof + procedure, pass(a) :: get_fmt => psb_s_get_fmt + procedure, pass(a) :: sizeof => psb_s_sizeof + ! Setters + procedure, pass(a) :: set_nrows => psb_s_set_nrows + procedure, pass(a) :: set_ncols => psb_s_set_ncols + procedure, pass(a) :: set_dupl => psb_s_set_dupl + procedure, pass(a) :: set_state => psb_s_set_state + procedure, pass(a) :: set_null => psb_s_set_null + procedure, pass(a) :: set_bld => psb_s_set_bld + procedure, pass(a) :: set_upd => psb_s_set_upd + procedure, pass(a) :: set_asb => psb_s_set_asb + procedure, pass(a) :: set_sorted => psb_s_set_sorted + procedure, pass(a) :: set_upper => psb_s_set_upper + procedure, pass(a) :: set_lower => psb_s_set_lower + procedure, pass(a) :: set_triangle => psb_s_set_triangle + procedure, pass(a) :: set_unit => psb_s_set_unit ! Memory/data management - procedure, pass(a) :: csall - procedure, pass(a) :: free - procedure, pass(a) :: trim - procedure, pass(a) :: csput - procedure, pass(a) :: s_csgetptn - procedure, pass(a) :: s_csgetrow - procedure, pass(a) :: s_csgetblk + procedure, pass(a) :: csall => psb_s_csall + procedure, pass(a) :: free => psb_s_free + procedure, pass(a) :: trim => psb_s_trim + procedure, pass(a) :: csput => psb_s_csput + procedure, pass(a) :: s_csgetptn => psb_s_csgetptn + procedure, pass(a) :: s_csgetrow => psb_s_csgetrow + procedure, pass(a) :: s_csgetblk => psb_s_csgetblk generic, public :: csget => s_csgetptn, s_csgetrow, s_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: s_clip_d_ip - procedure, pass(a) :: s_clip_d + procedure, pass(a) :: s_csclip => psb_s_csclip + procedure, pass(a) :: s_b_csclip => psb_s_b_csclip + generic, public :: csclip => s_b_csclip, s_csclip + procedure, pass(a) :: s_clip_d_ip => psb_s_clip_d_ip + procedure, pass(a) :: s_clip_d => psb_s_clip_d generic, public :: clip_diag => s_clip_d_ip, s_clip_d - procedure, pass(a) :: reall => reallocate_nz - procedure, pass(a) :: get_neigh - procedure, pass(a) :: s_cscnv - procedure, pass(a) :: s_cscnv_ip - generic, public :: cscnv => s_cscnv, s_cscnv_ip - procedure, pass(a) :: reinit - procedure, pass(a) :: print => sparse_print - procedure, pass(a) :: s_mv_from + procedure, pass(a) :: reall => psb_s_reallocate_nz + procedure, pass(a) :: get_neigh => psb_s_get_neigh + procedure, pass(a) :: s_cscnv => psb_s_cscnv + procedure, pass(a) :: s_cscnv_ip => psb_s_cscnv_ip + procedure, pass(a) :: s_cscnv_base => psb_s_cscnv_base + generic, public :: cscnv => s_cscnv, s_cscnv_ip, s_cscnv_base + procedure, pass(a) :: reinit => psb_s_reinit + procedure, pass(a) :: print => psb_s_sparse_print + procedure, pass(a) :: s_mv_from => psb_s_mv_from generic, public :: mv_from => s_mv_from - procedure, pass(a) :: s_mv_to + procedure, pass(a) :: s_mv_to => psb_s_mv_to generic, public :: mv_to => s_mv_to - procedure, pass(a) :: s_cp_from + procedure, pass(a) :: s_cp_from => psb_s_cp_from generic, public :: cp_from => s_cp_from - procedure, pass(a) :: s_cp_to + procedure, pass(a) :: s_cp_to => psb_s_cp_to generic, public :: cp_to => s_cp_to - procedure, pass(a) :: s_transp_1mat - procedure, pass(a) :: s_transp_2mat + procedure, pass(a) :: s_transp_1mat => psb_s_transp_1mat + procedure, pass(a) :: s_transp_2mat => psb_s_transp_2mat generic, public :: transp => s_transp_1mat, s_transp_2mat - procedure, pass(a) :: s_transc_1mat - procedure, pass(a) :: s_transc_2mat + procedure, pass(a) :: s_transc_1mat => psb_s_transc_1mat + procedure, pass(a) :: s_transc_2mat => psb_s_transc_2mat generic, public :: transc => s_transc_1mat, s_transc_2mat ! Computational routines - procedure, pass(a) :: get_diag - procedure, pass(a) :: csnmi - procedure, pass(a) :: s_csmv - procedure, pass(a) :: s_csmm + procedure, pass(a) :: get_diag => psb_s_get_diag + procedure, pass(a) :: csnmi => psb_s_csnmi + procedure, pass(a) :: s_csmv => psb_s_csmv + procedure, pass(a) :: s_csmm => psb_s_csmm generic, public :: csmm => s_csmm, s_csmv - procedure, pass(a) :: s_scals - procedure, pass(a) :: s_scal - generic, public :: scal => s_scals, s_scal - procedure, pass(a) :: s_cssv - procedure, pass(a) :: s_cssm + procedure, pass(a) :: s_scals => psb_s_scals + procedure, pass(a) :: s_scal => psb_s_scal + generic, public :: scal => s_scals, s_scal + procedure, pass(a) :: s_cssv => psb_s_cssv + procedure, pass(a) :: s_cssm => psb_s_cssm generic, public :: cssm => s_cssm, s_cssv end type psb_s_sparse_mat private :: get_nrows, get_ncols, get_nzeros, get_size, & & get_state, get_dupl, is_null, is_bld, is_upd, & - & is_asb, is_sorted, is_upper, is_lower, is_triangle, & - & is_unit, get_neigh, csall, csput, s_csgetrow, s_clip_d_ip, s_clip_d,& - & s_csgetblk, csclip, s_cscnv, s_cscnv_ip, & - & reallocate_nz, free, trim, & - & sparse_print, reinit, & - & set_nrows, set_ncols, set_dupl, & - & set_state, set_null, set_bld, & - & set_upd, set_asb, set_sorted, & - & set_upper, set_lower, set_triangle, & - & set_unit, get_diag, get_nz_row, s_csgetptn, & - & s_mv_from, s_mv_to, s_cp_from, s_cp_to,& - & s_transp_1mat, s_transp_2mat, & - & s_transc_1mat, s_transc_2mat + & is_asb, is_sorted, is_upper, is_lower, is_triangle interface psb_sizeof - module procedure s_sizeof + module procedure psb_s_sizeof + end interface + + + !===================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !===================================== + + + interface + subroutine psb_s_set_nrows(m,a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + end subroutine psb_s_set_nrows + end interface + + interface + subroutine psb_s_set_ncols(n,a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_s_set_ncols + end interface + + interface + subroutine psb_s_set_state(n,a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_s_set_state + end interface + + interface + subroutine psb_s_set_dupl(n,a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_s_set_dupl + end interface + + interface + subroutine psb_s_set_null(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_set_null + end interface + + interface + subroutine psb_s_set_bld(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_set_bld + end interface + + interface + subroutine psb_s_set_upd(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_set_upd + end interface + + interface + subroutine psb_s_set_asb(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_set_asb + end interface + + interface + subroutine psb_s_set_sorted(a,val) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_sorted + end interface + + interface + subroutine psb_s_set_triangle(a,val) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_triangle + end interface + + interface + subroutine psb_s_set_unit(a,val) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_unit + end interface + + interface + subroutine psb_s_set_lower(a,val) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_lower + end interface + + interface + subroutine psb_s_set_upper(a,val) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_upper + end interface + + + interface + subroutine psb_s_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_s_sparse_mat + integer, intent(in) :: iout + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_s_sparse_print + end interface + + interface + subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_s_get_neigh + end interface + + interface + subroutine psb_s_csall(nr,nc,a,info,nz) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + end subroutine psb_s_csall + end interface + + interface + subroutine psb_s_reallocate_nz(nz,a) + import psb_s_sparse_mat + integer, intent(in) :: nz + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_reallocate_nz + end interface + + interface + subroutine psb_s_free(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_free + end interface + + interface + subroutine psb_s_trim(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_trim + end interface + + interface + subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_s_csput + end interface + + interface + subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csgetptn + end interface + + interface + subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csgetrow + end interface + + interface + subroutine psb_s_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csgetblk + end interface + + interface + subroutine psb_s_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csclip + end interface + + interface + subroutine psb_s_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_s_sparse_mat, psb_spk_, psb_s_coo_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_b_csclip end interface + + interface + subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_s_cscnv + end interface + + + interface + subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(out) :: iinfo + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_s_cscnv_ip + end interface + + interface + subroutine psb_s_cscnv_base(a,b,info,dupl) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + end subroutine psb_s_cscnv_base + end interface + + interface + subroutine psb_s_clip_d(a,b,info) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer,intent(out) :: info + end subroutine psb_s_clip_d + end interface + + interface + subroutine psb_s_clip_d_ip(a,info) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + end subroutine psb_s_clip_d_ip + end interface + + interface + subroutine psb_s_mv_from(a,b) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_mv_from + end interface + + interface + subroutine psb_s_cp_from(a,b) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + end subroutine psb_s_cp_from + end interface + + interface + subroutine psb_s_mv_to(a,b) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + end subroutine psb_s_mv_to + end interface + + interface + subroutine psb_s_cp_to(a,b) + import psb_s_sparse_mat, psb_spk_, psb_s_base_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + end subroutine psb_s_cp_to + end interface + interface psb_move_alloc - module procedure s_sparse_mat_move + subroutine psb_s_sparse_mat_move(a,b,info) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_s_sparse_mat_move end interface + interface psb_clone - module procedure s_sparse_mat_clone + subroutine psb_s_sparse_mat_clone(a,b,info) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_s_sparse_mat_clone + end interface + + interface + subroutine psb_s_transp_1mat(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_transp_1mat + end interface + + interface + subroutine psb_s_transp_2mat(a,b) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_sparse_mat), intent(in) :: b + end subroutine psb_s_transp_2mat + end interface + + interface + subroutine psb_s_transc_1mat(a) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + end subroutine psb_s_transc_1mat + end interface + + interface + subroutine psb_s_transc_2mat(a,b) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_sparse_mat), intent(in) :: b + end subroutine psb_s_transc_2mat + end interface + + interface + subroutine psb_s_reinit(a,clear) + import psb_s_sparse_mat + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_s_reinit + end interface + + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== interface psb_csmm - module procedure s_csmm, s_csmv + subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_csmm + subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_csmv end interface - + interface psb_cssm - module procedure s_cssm, s_cssv + subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_s_cssm + subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_s_cssv end interface - - interface psb_csnmi - module procedure csnmi + + interface + function psb_s_csnmi(a) result(res) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_s_csnmi + end interface + + interface + subroutine psb_s_get_diag(a,d,info) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_get_diag end interface interface psb_scal - module procedure s_scals, s_scal + subroutine psb_s_scal(d,a,info) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_s_scal + subroutine psb_s_scals(d,a,info) + import psb_s_sparse_mat, psb_spk_ + class(psb_s_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_s_scals end interface + + + contains @@ -156,7 +610,7 @@ contains !===================================== - function s_sizeof(a) result(res) + function psb_s_sizeof(a) result(res) implicit none class(psb_s_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res @@ -166,11 +620,11 @@ contains res = a%a%sizeof() end if - end function s_sizeof + end function psb_s_sizeof - function sparse_get_fmt(a) result(res) + function psb_s_get_fmt(a) result(res) implicit none class(psb_s_sparse_mat), intent(in) :: a character(len=5) :: res @@ -181,12 +635,11 @@ contains res = 'NULL' end if - end function sparse_get_fmt + end function psb_s_get_fmt function get_dupl(a) result(res) - use psb_error_mod implicit none class(psb_s_sparse_mat), intent(in) :: a integer :: res @@ -357,73 +810,33 @@ contains function get_nzeros(a) result(res) - use psb_error_mod implicit none class(psb_s_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_nzeros() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() end if end function get_nzeros function get_size(a) result(res) - use psb_error_mod + implicit none class(psb_s_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_size' - logical, parameter :: debug=.false. - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_size() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() end if - return end function get_size function get_nz_row(idx,a) result(res) - use psb_error_mod implicit none integer, intent(in) :: idx class(psb_s_sparse_mat), intent(in) :: a @@ -438,1797 +851,4 @@ contains end function get_nz_row - - !===================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine set_nrows(m,a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - integer, intent(in) :: m - Integer :: err_act, info - character(len=20) :: name='set_nrows' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_nrows(m) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_nrows - - subroutine set_ncols(n,a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_ncols(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_ncols - - - subroutine set_state(n,a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_state(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_state - - - subroutine set_dupl(n,a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_dupl(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_dupl - - subroutine set_null(a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_null() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_null - - subroutine set_bld(a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_bld() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_bld - - subroutine set_upd(a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upd() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_upd - - subroutine set_asb(a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_asb() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_asb - - subroutine set_sorted(a,val) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_sorted(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_sorted - - subroutine set_triangle(a,val) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_triangle(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_triangle - - subroutine set_unit(a,val) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_unit(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_unit - - subroutine set_lower(a,val) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_lower(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_lower - - subroutine set_upper(a,val) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upper(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_upper - - - !===================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !===================================== - - - subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_error_mod - implicit none - - integer, intent(in) :: iout - class(psb_s_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act, info - character(len=20) :: name='sparse_print' - logical, parameter :: debug=.false. - - info = 0 - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine sparse_print - - - - subroutine get_neigh(a,idx,neigh,n,info,lev) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable, intent(out) :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - - Integer :: err_act - character(len=20) :: name='get_neigh' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_neigh(idx,neigh,n,info,lev) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_neigh - - - subroutine csall(nr,nc,a,info,nz) - use psb_s_base_mat_mod - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(out) :: a - integer, intent(in) :: nr,nc - integer, intent(out) :: info - integer, intent(in), optional :: nz - - Integer :: err_act - character(len=20) :: name='csall' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - allocate(psb_s_coo_sparse_mat :: a%a, stat=info) - if (info /= 0) then - info = 4000 - call psb_errpush(info, name) - goto 9999 - end if - call a%a%allocate(nr,nc,nz) - call a%set_bld() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csall - - subroutine reallocate_nz(nz,a) - use psb_error_mod - implicit none - integer, intent(in) :: nz - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='reallocate_nz' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reallocate(nz) - - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine reallocate_nz - - subroutine free(a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='free' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%free() - deallocate(a%a) - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine free - - subroutine trim(a) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%trim() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine trim - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_s_base_mat_mod - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.a%is_bld()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csput - - subroutine s_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod - implicit none - - class(psb_s_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_csgetptn - - subroutine s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod - implicit none - - class(psb_s_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_csgetrow - - - - subroutine s_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod - implicit none - - class(psb_s_sparse_mat), intent(in) :: a - class(psb_s_sparse_mat), intent(out) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat), allocatable :: acoo - - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - - if (info == 0) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_csgetblk - - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod - implicit none - - class(psb_s_sparse_mat), intent(in) :: a - class(psb_s_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csclip' - logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat), allocatable :: acoo - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csclip - - - - subroutine s_cscnv(a,b,info,type,mold,upd,dupl) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - class(psb_s_sparse_mat), intent(out) :: b - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_s_base_sparse_mat), intent(in), optional :: mold - - - class(psb_s_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call b%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call b%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_s_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - call b%set_asb() - call b%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_cscnv - - - subroutine s_cscnv_ip(a,info,type,mold,dupl) - use psb_error_mod - use psb_string_mod - implicit none - - class(psb_s_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_s_base_sparse_mat), intent(in), optional :: mold - - - class(psb_s_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv_ip' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - 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 = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_s_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%mv_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,a%a) - call a%set_asb() - call a%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_cscnv_ip - - subroutine s_clip_d(a,b,info) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod - implicit none - - class(psb_s_sparse_mat), intent(in) :: a - class(psb_s_sparse_mat), intent(out) :: b - integer,intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clip_diag' - logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat), allocatable :: acoo - integer :: i, j, nz - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%cp_to_coo(acoo,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - nz = acoo%get_nzeros() - j = 0 - do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 - acoo%ia(j) = acoo%ia(i) - acoo%ja(j) = acoo%ja(i) - acoo%val(j) = acoo%val(i) - end if - end do - call acoo%set_nzeros(j) - call acoo%trim() - call b%mv_from(acoo) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_clip_d - - - subroutine s_clip_d_ip(a,info) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_s_base_mat_mod - implicit none - - class(psb_s_sparse_mat), intent(inout) :: a - integer,intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clip_diag' - logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat), allocatable :: acoo - integer :: i, j, nz - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%mv_to_coo(acoo,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - nz = acoo%get_nzeros() - j = 0 - do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 - acoo%ia(j) = acoo%ia(i) - acoo%ja(j) = acoo%ja(i) - acoo%val(j) = acoo%val(i) - end if - end do - call acoo%set_nzeros(j) - call acoo%trim() - call a%mv_from(acoo) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_clip_d_ip - - subroutine s_mv_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(out) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer :: info - - allocate(a%a,source=b, stat=info) - call a%a%mv_from_fmt(b,info) - - return - end subroutine s_mv_from - - subroutine s_cp_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(out) :: a - class(psb_s_base_sparse_mat), intent(inout), allocatable :: b - Integer :: err_act, info - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine s_cp_from - - subroutine s_mv_to(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer :: info - - call b%mv_from_fmt(a%a,info) - - return - end subroutine s_mv_to - - subroutine s_cp_to(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer :: info - - call b%cp_from_fmt(a%a,info) - - return - end subroutine s_cp_to - - subroutine s_sparse_mat_move(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - class(psb_s_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='move_alloc' - logical, parameter :: debug=.false. - - info = 0 - call move_alloc(a%a,b%a) - - return - end subroutine s_sparse_mat_move - - subroutine s_sparse_mat_clone(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - class(psb_s_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_sparse_mat_clone - - - subroutine s_transp_1mat(a) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - - Integer :: err_act, info - character(len=20) :: name='transp' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%transp() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_transp_1mat - - - subroutine s_transp_2mat(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(out) :: a - class(psb_s_sparse_mat), intent(in) :: b - - Integer :: err_act, info - character(len=20) :: name='transp' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (b%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 - goto 9999 - end if - call a%a%transp(b%a) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_transp_2mat - - subroutine s_transc_1mat(a) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - - Integer :: err_act, info - character(len=20) :: name='transc' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%transc() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_transc_1mat - - - subroutine s_transc_2mat(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_s_sparse_mat), intent(out) :: a - class(psb_s_sparse_mat), intent(in) :: b - - Integer :: err_act, info - character(len=20) :: name='transc' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - if (b%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 - goto 9999 - end if - call a%a%transc(b%a) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine s_transc_2mat - - - subroutine reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_s_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - Integer :: err_act, info - character(len=20) :: name='reinit' - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reinit(clear) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine reinit - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine s_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csmm - - subroutine s_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_csmv - - subroutine s_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_cssm - - subroutine s_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_cssv - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%csnmi() - - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end function csnmi - - - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_diag(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_diag - - subroutine s_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_scal - - subroutine s_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_s_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_scals - - end module psb_s_mat_mod diff --git a/base/modules/psb_sort_mod.f90 b/base/modules/psb_sort_mod.f90 index a1673ed6..eec04e97 100644 --- a/base/modules/psb_sort_mod.f90 +++ b/base/modules/psb_sort_mod.f90 @@ -85,4536 +85,564 @@ module psb_sort_mod integer, allocatable :: idxs(:) end type psb_dcomplex_idx_heap + + interface psb_ibsrch + function psb_ibsrch(key,n,v) result(ipos) + integer ipos, key, n + integer v(n) + end function psb_ibsrch + end interface + + interface psb_issrch + function psb_issrch(key,n,v) result(ipos) + implicit none + integer ipos, key, n + integer v(n) + end function psb_issrch + end interface + + interface psb_isaperm + logical function psb_isaperm(n,eip) + integer, intent(in) :: n + integer, intent(in) :: eip(n) + integer, allocatable :: ip(:) + end function psb_isaperm + end interface + + interface psb_msort - module procedure imsort, dmsort, zamsort, smsort, camsort + subroutine imsort(x,ix,dir,flag) + integer, intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine imsort + subroutine smsort(x,ix,dir,flag) + use psb_const_mod + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine smsort + subroutine dmsort(x,ix,dir,flag) + use psb_const_mod + real(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine dmsort + subroutine camsort(x,ix,dir,flag) + use psb_const_mod + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine camsort + subroutine zamsort(x,ix,dir,flag) + use psb_const_mod + complex(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine zamsort end interface + interface psb_msort_unique - module procedure imsort_u + subroutine imsort_u(x,nout,dir) + integer, intent(inout) :: x(:) + integer, intent(out) :: nout + integer, optional, intent(in) :: dir + end subroutine imsort_u end interface interface psb_qsort - module procedure iqsort, sqsort, cqsort, dqsort, zqsort + subroutine iqsort(x,ix,dir,flag) + integer, intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine iqsort + subroutine sqsort(x,ix,dir,flag) + use psb_const_mod + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine sqsort + subroutine dqsort(x,ix,dir,flag) + use psb_const_mod + real(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine dqsort + subroutine cqsort(x,ix,dir,flag) + use psb_const_mod + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine cqsort + subroutine zqsort(x,ix,dir,flag) + use psb_const_mod + complex(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine zqsort end interface + interface psb_hsort - module procedure ihsort, shsort, chsort, dhsort, zhsort +!!$ module procedure ihsort, shsort, chsort, dhsort, zhsort + subroutine ihsort(x,ix,dir,flag) + use psb_const_mod + integer, intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine ihsort + subroutine shsort(x,ix,dir,flag) + use psb_const_mod + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine shsort + subroutine dhsort(x,ix,dir,flag) + use psb_const_mod + real(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine dhsort + subroutine chsort(x,ix,dir,flag) + use psb_const_mod + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine chsort + subroutine zhsort(x,ix,dir,flag) + use psb_const_mod + complex(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + end subroutine zhsort + end interface + + + interface psb_howmany_heap + function psb_howmany_int_heap(heap) + import psb_int_heap + type(psb_int_heap), intent(in) :: heap + integer :: psb_howmany_int_heap + end function psb_howmany_int_heap + function psb_howmany_real_idx_heap(heap) + import psb_real_idx_heap + type(psb_real_idx_heap), intent(in) :: heap + integer :: psb_howmany_real_idx_heap + end function psb_howmany_real_idx_heap + function psb_howmany_double_idx_heap(heap) + import psb_double_idx_heap + type(psb_double_idx_heap), intent(in) :: heap + integer :: psb_howmany_double_idx_heap + end function psb_howmany_double_idx_heap + function psb_howmany_int_idx_heap(heap) + import psb_int_idx_heap + type(psb_int_idx_heap), intent(in) :: heap + integer :: psb_howmany_int_idx_heap + end function psb_howmany_int_idx_heap + function psb_howmany_scomplex_idx_heap(heap) + import psb_scomplex_idx_heap + type(psb_scomplex_idx_heap), intent(in) :: heap + integer :: psb_howmany_scomplex_idx_heap + end function psb_howmany_scomplex_idx_heap + function psb_howmany_dcomplex_idx_heap(heap) + import psb_dcomplex_idx_heap + type(psb_dcomplex_idx_heap), intent(in) :: heap + integer :: psb_howmany_dcomplex_idx_heap + end function psb_howmany_dcomplex_idx_heap end interface + interface psb_init_heap - module procedure psb_init_int_heap, psb_init_int_idx_heap,& - & psb_init_double_idx_heap, psb_init_dcomplex_idx_heap, & - & psb_init_real_idx_heap, psb_init_scomplex_idx_heap + subroutine psb_init_int_heap(heap,info,dir) + import psb_int_heap + type(psb_int_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + end subroutine psb_init_int_heap + subroutine psb_init_real_idx_heap(heap,info,dir) + import psb_real_idx_heap + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + end subroutine psb_init_real_idx_heap + subroutine psb_init_int_idx_heap(heap,info,dir) + import psb_int_idx_heap + type(psb_int_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + end subroutine psb_init_int_idx_heap + subroutine psb_init_scomplex_idx_heap(heap,info,dir) + import psb_scomplex_idx_heap + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + end subroutine psb_init_scomplex_idx_heap + subroutine psb_init_dcomplex_idx_heap(heap,info,dir) + import psb_dcomplex_idx_heap + type(psb_dcomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + end subroutine psb_init_dcomplex_idx_heap + subroutine psb_init_double_idx_heap(heap,info,dir) + import psb_double_idx_heap + type(psb_double_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + end subroutine psb_init_double_idx_heap end interface + interface psb_dump_heap - module procedure psb_dump_int_heap, psb_dump_int_idx_heap,& - & psb_dump_real_idx_heap, psb_dump_scomplex_idx_heap, & - & psb_dump_double_idx_heap, psb_dump_dcomplex_idx_heap + subroutine psb_dump_int_heap(iout,heap,info) + import psb_int_heap + type(psb_int_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + end subroutine psb_dump_int_heap + subroutine psb_dump_real_idx_heap(iout,heap,info) + import psb_real_idx_heap + type(psb_real_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + end subroutine psb_dump_real_idx_heap + subroutine psb_dump_double_idx_heap(iout,heap,info) + import psb_double_idx_heap + type(psb_double_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + end subroutine psb_dump_double_idx_heap + subroutine psb_dump_int_idx_heap(iout,heap,info) + import psb_int_idx_heap + type(psb_int_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + end subroutine psb_dump_int_idx_heap + subroutine psb_dump_scomplex_idx_heap(iout,heap,info) + import psb_scomplex_idx_heap + type(psb_scomplex_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + end subroutine psb_dump_scomplex_idx_heap + subroutine psb_dump_dcomplex_idx_heap(iout,heap,info) + import psb_dcomplex_idx_heap + type(psb_dcomplex_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + end subroutine psb_dump_dcomplex_idx_heap end interface - interface psb_howmany_heap - module procedure psb_howmany_int_heap, psb_howmany_int_idx_heap,& - & psb_howmany_real_idx_heap, psb_howmany_scomplex_idx_heap,& - & psb_howmany_double_idx_heap, psb_howmany_dcomplex_idx_heap - end interface interface psb_insert_heap - module procedure psb_insert_int_heap, psb_insert_int_idx_heap,& - & psb_insert_real_idx_heap, psb_insert_scomplex_idx_heap,& - & psb_insert_double_idx_heap, psb_insert_dcomplex_idx_heap + subroutine psb_insert_int_heap(key,heap,info) + import psb_int_heap + integer, intent(in) :: key + type(psb_int_heap), intent(inout) :: heap + integer, intent(out) :: info + end subroutine psb_insert_int_heap + subroutine psb_insert_int_idx_heap(key,index,heap,info) + import psb_dpk_, psb_int_idx_heap + integer, intent(in) :: key + integer, intent(in) :: index + type(psb_int_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + end subroutine psb_insert_int_idx_heap + subroutine psb_insert_real_idx_heap(key,index,heap,info) + import psb_spk_, psb_real_idx_heap + real(psb_spk_), intent(in) :: key + integer, intent(in) :: index + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + end subroutine psb_insert_real_idx_heap + subroutine psb_insert_double_idx_heap(key,index,heap,info) + import psb_dpk_, psb_double_idx_heap + real(psb_dpk_), intent(in) :: key + integer, intent(in) :: index + type(psb_double_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + end subroutine psb_insert_double_idx_heap + subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) + import psb_spk_, psb_scomplex_idx_heap + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: index + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + end subroutine psb_insert_scomplex_idx_heap + subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) + import psb_dpk_, psb_dcomplex_idx_heap + complex(psb_dpk_), intent(in) :: key + integer, intent(in) :: index + type(psb_dcomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + end subroutine psb_insert_dcomplex_idx_heap end interface interface psb_heap_get_first - module procedure psb_int_heap_get_first, psb_int_idx_heap_get_first,& - & psb_real_idx_heap_get_first, psb_scomplex_idx_heap_get_first,& - & psb_double_idx_heap_get_first, psb_dcomplex_idx_heap_get_first + subroutine psb_int_heap_get_first(key,heap,info) + import psb_int_heap + type(psb_int_heap), intent(inout) :: heap + integer, intent(out) :: key,info + end subroutine psb_int_heap_get_first + subroutine psb_int_idx_heap_get_first(key,index,heap,info) + import psb_int_idx_heap + type(psb_int_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + integer, intent(out) :: key + end subroutine psb_int_idx_heap_get_first + subroutine psb_real_idx_heap_get_first(key,index,heap,info) + import psb_spk_, psb_real_idx_heap + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + real(psb_spk_), intent(out) :: key + end subroutine psb_real_idx_heap_get_first + subroutine psb_double_idx_heap_get_first(key,index,heap,info) + import psb_dpk_, psb_double_idx_heap + type(psb_double_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + real(psb_dpk_), intent(out) :: key + end subroutine psb_double_idx_heap_get_first + subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) + import psb_spk_, psb_scomplex_idx_heap + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + complex(psb_spk_), intent(out) :: key + end subroutine psb_scomplex_idx_heap_get_first + + subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info) + import psb_dpk_, psb_dcomplex_idx_heap + type(psb_dcomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + complex(psb_dpk_), intent(out) :: key + end subroutine psb_dcomplex_idx_heap_get_first end interface - interface psb_ibsrch - module procedure psb_ibsrch + interface + subroutine psi_insert_int_heap(key,last,heap,dir,info) + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer, intent(in) :: key,dir + integer, intent(inout) :: heap(:),last + integer, intent(out) :: info + end subroutine psi_insert_int_heap end interface - interface psb_issrch - module procedure psb_issrch + + interface + subroutine psi_int_heap_get_first(key,last,heap,dir,info) + implicit none + + integer, intent(inout) :: key,last + integer, intent(in) :: dir + integer, intent(inout) :: heap(:) + integer, intent(out) :: info + end subroutine psi_int_heap_get_first end interface - - interface psb_isaperm - module procedure psb_isaperm + + interface + subroutine psi_insert_real_heap(key,last,heap,dir,info) + import psb_spk_ + real(psb_spk_), intent(in) :: key + integer, intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + real(psb_spk_) :: temp + end subroutine psi_insert_real_heap + end interface + + interface + subroutine psi_real_heap_get_first(key,last,heap,dir,info) + import psb_spk_ + real(psb_spk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: info + end subroutine psi_real_heap_get_first + end interface + + interface + subroutine psi_insert_double_heap(key,last,heap,dir,info) + import psb_dpk_ + real(psb_dpk_), intent(in) :: key + integer, intent(in) :: dir + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + real(psb_dpk_) :: temp + end subroutine psi_insert_double_heap + end interface + + interface + subroutine psi_double_heap_get_first(key,last,heap,dir,info) + import psb_dpk_ + real(psb_dpk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: info + end subroutine psi_double_heap_get_first + end interface + + interface + subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) + import psb_spk_ + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + end subroutine psi_insert_scomplex_heap + end interface + + interface + subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) + import psb_spk_ + complex(psb_spk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: info + end subroutine psi_scomplex_heap_get_first + end interface + + interface + subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) + import psb_dpk_ + complex(psb_dpk_), intent(in) :: key + integer, intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + end subroutine psi_insert_dcomplex_heap + end interface + + interface + subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info) + import psb_dpk_ + complex(psb_dpk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: info + end subroutine psi_dcomplex_heap_get_first end interface -contains - - logical function psb_isaperm(n,eip) - implicit none - - integer, intent(in) :: n - integer, intent(in) :: eip(n) - integer, allocatable :: ip(:) - integer i,j,m, info - - - psb_isaperm = .true. - if (n <= 0) return - allocate(ip(n), stat=info) - if (info /= 0) return - ! - ! sanity check first - ! - do i=1, n - ip(i) = eip(i) - if ((ip(i) < 1).or.(ip(i) > n)) then - write(0,*) 'Out of bounds in isaperm' ,ip(i), n - psb_isaperm = .false. - return - endif - enddo - - ! - ! now work through the cycles, by marking each successive item as negative. - ! no cycle should intersect with any other, hence the >= 1 check. - ! - do m = 1, n - i = ip(m) - if (i < 0) then - ip(m) = -i - else if (i /= m) then - j = ip(i) - ip(i) = -j - i = j - do while ((j >= 1).and.(j /= m)) - j = ip(i) - ip(i) = -j - i = j - enddo - ip(m) = iabs(ip(m)) - if (j /= m) then - psb_isaperm = .false. - goto 9999 - endif - end if - enddo -9999 continue - - return - end function psb_isaperm - - function psb_ibsrch(key,n,v) result(ipos) - implicit none - integer ipos, key, n - integer v(n) - - integer lb, ub, m - - lb = 1 - ub = n - ipos = -1 - - do while (lb.le.ub) - m = (lb+ub)/2 - if (key.eq.v(m)) then - ipos = m - lb = ub + 1 - else if (key < v(m)) then - ub = m-1 - else - lb = m + 1 - end if - enddo - return - end function psb_ibsrch - - function psb_issrch(key,n,v) result(ipos) - implicit none - integer ipos, key, n - integer v(n) - - integer i - - ipos = -1 - do i=1,n - if (key.eq.v(i)) then - ipos = i - return - end if - enddo - return - end function psb_issrch - - - subroutine imsort(x,ix,dir,flag) - use psb_error_mod - implicit none - integer, intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_msort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - call imsrx(n,x,ix,dir_,flag_) - else - call imsr(n,x,dir_) - end if - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine imsort - - - subroutine smsort(x,ix,dir,flag) - use psb_error_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_msort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - call smsrx(n,x,ix,dir_,flag_) - else - call smsr(n,x,dir_) - end if - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine smsort - - subroutine dmsort(x,ix,dir,flag) - use psb_error_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_msort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - call dmsrx(n,x,ix,dir_,flag_) - else - call dmsr(n,x,dir_) - end if - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine dmsort - - subroutine camsort(x,ix,dir,flag) - use psb_error_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_msort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_asort_up_ - end if - select case(dir_) - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - call camsrx(n,x,ix,dir_,flag_) - else - call camsr(n,x,dir_) - end if - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine camsort - - subroutine zamsort(x,ix,dir,flag) - use psb_error_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_msort' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_asort_up_ - end if - select case(dir_) - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - call zamsrx(n,x,ix,dir_,flag_) - else - call zamsr(n,x,dir_) - end if - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine zamsort - - - subroutine imsort_u(x,nout,dir) - use psb_error_mod - implicit none - integer, intent(inout) :: x(:) - integer, intent(out) :: nout - integer, optional, intent(in) :: dir - - integer :: dir_, n, err_act - - character(len=20) :: name - - name='psb_msort_u' - call psb_erractionsave(err_act) - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - call imsru(n,x,dir_,nout) - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine imsort_u - - - subroutine iqsort(x,ix,dir,flag) - use psb_error_mod - implicit none - integer, intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_qsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - - n = size(x) - - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call isrx(n,x,ix,dir_,flag_) - else - call isr(n,x,dir_) - end if - - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call iasrx(n,x,ix,dir_,flag_) - else - call iasr(n,x,dir_) - end if - - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine iqsort - - - subroutine sqsort(x,ix,dir,flag) - use psb_error_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_qsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - - n = size(x) - - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call ssrx(n,x,ix,dir_,flag_) - else - call ssr(n,x,dir_) - end if - - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call sasrx(n,x,ix,dir_,flag_) - else - call sasr(n,x,dir_) - end if - - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine sqsort - - subroutine dqsort(x,ix,dir,flag) - use psb_error_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_qsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - - n = size(x) - - select case(dir_) - case( psb_sort_up_, psb_sort_down_) - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call dsrx(n,x,ix,dir_,flag_) - else - call dsr(n,x,dir_) - end if - - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call dasrx(n,x,ix,dir_,flag_) - else - call dasr(n,x,dir_) - end if - - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine dqsort - - - subroutine cqsort(x,ix,dir,flag) - use psb_error_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_qsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_lsort_up_ - end if - - n = size(x) - - select case(dir_) - case( psb_lsort_up_, psb_lsort_down_) - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call clsrx(n,x,ix,dir_,flag_) - else - call clsr(n,x,dir_) - end if - - case( psb_alsort_up_, psb_alsort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call calsrx(n,x,ix,dir_,flag_) - else - call calsr(n,x,dir_) - end if - - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call casrx(n,x,ix,dir_,flag_) - else - call casr(n,x,dir_) - end if - - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine cqsort - - - subroutine zqsort(x,ix,dir,flag) - use psb_error_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, err_act - - character(len=20) :: name - - name='psb_qsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_lsort_up_ - end if - - n = size(x) - - select case(dir_) - case( psb_lsort_up_, psb_lsort_down_) - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call zlsrx(n,x,ix,dir_,flag_) - else - call zlsr(n,x,dir_) - end if - - case( psb_alsort_up_, psb_alsort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call zalsrx(n,x,ix,dir_,flag_) - else - call zalsr(n,x,dir_) - end if - - case( psb_asort_up_, psb_asort_down_) - ! OK keep going - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - - call zasrx(n,x,ix,dir_,flag_) - else - call zasr(n,x,dir_) - end if - - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine zqsort - - - - - subroutine ihsort(x,ix,dir,flag) - use psb_error_mod - implicit none - integer, intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, i, l, err_act,info - integer :: key - integer :: index - - character(len=20) :: name - - name='psb_hsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - - select case(dir_) - case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! OK - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - ! - ! Dirty trick to sort with heaps: if we want - ! to sort in place upwards, first we set up a heap so that - ! we can easily get the LARGEST element, then we take it out - ! and put it in the last entry, and so on. - ! So, we invert dir_! - ! - dir_ = -dir_ - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (flag_==psb_sort_ovw_idx_) then - do i=1, n - ix(i) = i - end do - end if - l = 0 - do i=1, n - key = x(i) - index = ix(i) - call psi_insert_int_idx_heap(key,index,l,x,ix,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ' - end if - end do - do i=n, 2, -1 - call psi_int_idx_heap_get_first(key,index,l,x,ix,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - ix(i) = index - end do - else if (.not.present(ix)) then - l = 0 - do i=1, n - key = x(i) - call psi_insert_int_heap(key,l,x,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ',l,i - end if - end do - do i=n, 2, -1 - call psi_int_heap_get_first(key,l,x,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - end do - end if - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine ihsort - - - subroutine shsort(x,ix,dir,flag) - use psb_error_mod - implicit none - real(psb_spk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, i, l, err_act,info - real(psb_spk_) :: key - integer :: index - - character(len=20) :: name - - name='psb_hsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - - select case(dir_) - case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! OK - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - ! - ! Dirty trick to sort with heaps: if we want - ! to sort in place upwards, first we set up a heap so that - ! we can easily get the LARGEST element, then we take it out - ! and put it in the last entry, and so on. - ! So, we invert dir_! - ! - dir_ = -dir_ - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (flag_==psb_sort_ovw_idx_) then - do i=1, n - ix(i) = i - end do - end if - l = 0 - do i=1, n - key = x(i) - index = ix(i) - call psi_insert_real_idx_heap(key,index,l,x,ix,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ' - end if - end do - do i=n, 2, -1 - call psi_real_idx_heap_get_first(key,index,l,x,ix,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - ix(i) = index - end do - else if (.not.present(ix)) then - l = 0 - do i=1, n - key = x(i) - call psi_insert_real_heap(key,l,x,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ',l,i - end if - end do - do i=n, 2, -1 - call psi_real_heap_get_first(key,l,x,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - end do - end if - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine shsort - - - subroutine dhsort(x,ix,dir,flag) - use psb_error_mod - implicit none - real(psb_dpk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, i, l, err_act,info - real(psb_dpk_) :: key - integer :: index - - character(len=20) :: name - - name='psb_hsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_sort_up_ - end if - - select case(dir_) - case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! OK - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - ! - ! Dirty trick to sort with heaps: if we want - ! to sort in place upwards, first we set up a heap so that - ! we can easily get the LARGEST element, then we take it out - ! and put it in the last entry, and so on. - ! So, we invert dir_! - ! - dir_ = -dir_ - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (flag_==psb_sort_ovw_idx_) then - do i=1, n - ix(i) = i - end do - end if - l = 0 - do i=1, n - key = x(i) - index = ix(i) - call psi_insert_double_idx_heap(key,index,l,x,ix,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ' - end if - end do - do i=n, 2, -1 - call psi_double_idx_heap_get_first(key,index,l,x,ix,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - ix(i) = index - end do - else if (.not.present(ix)) then - l = 0 - do i=1, n - key = x(i) - call psi_insert_double_heap(key,l,x,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ',l,i - end if - end do - do i=n, 2, -1 - call psi_double_heap_get_first(key,l,x,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - end do - end if - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine dhsort - - - subroutine chsort(x,ix,dir,flag) - use psb_error_mod - implicit none - complex(psb_spk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, i, l, err_act,info - complex(psb_spk_) :: key - integer :: index - - character(len=20) :: name - - name='psb_hsort' - call psb_erractionsave(err_act) - - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_asort_up_ - end if - - select case(dir_) - case(psb_asort_up_,psb_asort_down_) - ! OK - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) - - ! - ! Dirty trick to sort with heaps: if we want - ! to sort in place upwards, first we set up a heap so that - ! we can easily get the LARGEST element, then we take it out - ! and put it in the last entry, and so on. - ! So, we invert dir_! - ! - dir_ = -dir_ - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (flag_==psb_sort_ovw_idx_) then - do i=1, n - ix(i) = i - end do - end if - l = 0 - do i=1, n - key = x(i) - index = ix(i) - call psi_insert_scomplex_idx_heap(key,index,l,x,ix,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ' - end if - end do - do i=n, 2, -1 - call psi_scomplex_idx_heap_get_first(key,index,l,x,ix,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - ix(i) = index - end do - else if (.not.present(ix)) then - l = 0 - do i=1, n - key = x(i) - call psi_insert_scomplex_heap(key,l,x,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ',l,i - end if - end do - do i=n, 2, -1 - call psi_scomplex_heap_get_first(key,l,x,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - end do - end if - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine chsort - + interface + subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info) + integer, intent(in) :: key + integer, intent(in) :: index,dir + integer, intent(inout) :: heap(:),last + integer, intent(inout) :: idxs(:) + integer, intent(out) :: info + end subroutine psi_insert_int_idx_heap + end interface + + interface + subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + integer, intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + integer, intent(out) :: key + end subroutine psi_int_idx_heap_get_first + end interface + + interface + subroutine psi_insert_real_idx_heap(key,index,last,heap,idxs,dir,info) + import psb_spk_ + real(psb_spk_), intent(in) :: key + integer, intent(in) :: index,dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + end subroutine psi_insert_real_idx_heap + end interface + + interface + subroutine psi_real_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import psb_spk_ + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + real(psb_spk_), intent(out) :: key + end subroutine psi_real_idx_heap_get_first + end interface - subroutine zhsort(x,ix,dir,flag) - use psb_error_mod - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - integer, optional, intent(in) :: dir, flag - integer, optional, intent(inout) :: ix(:) - - integer :: dir_, flag_, n, i, l, err_act,info - complex(psb_dpk_) :: key - integer :: index - - character(len=20) :: name + interface + subroutine psi_insert_double_idx_heap(key,index,last,heap,idxs,dir,info) + import psb_dpk_ + real(psb_dpk_), intent(in) :: key + integer, intent(in) :: index,dir + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + end subroutine psi_insert_double_idx_heap + end interface + + interface + subroutine psi_double_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import psb_dpk_ + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + real(psb_dpk_), intent(out) :: key + end subroutine psi_double_idx_heap_get_first + end interface - name='psb_hsort' - call psb_erractionsave(err_act) + interface + subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) + import psb_spk_ + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: index,dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + end subroutine psi_insert_scomplex_idx_heap + end interface - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ - end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select - - if (present(dir)) then - dir_ = dir - else - dir_= psb_asort_up_ - end if - - select case(dir_) - case(psb_asort_up_,psb_asort_down_) - ! OK - case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) - goto 9999 - end select - - n = size(x) + interface + subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import psb_spk_ + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + complex(psb_spk_), intent(out) :: key + end subroutine psi_scomplex_idx_heap_get_first + end interface - ! - ! Dirty trick to sort with heaps: if we want - ! to sort in place upwards, first we set up a heap so that - ! we can easily get the LARGEST element, then we take it out - ! and put it in the last entry, and so on. - ! So, we invert dir_! - ! - dir_ = -dir_ - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 - end if - if (flag_==psb_sort_ovw_idx_) then - do i=1, n - ix(i) = i - end do - end if - l = 0 - do i=1, n - key = x(i) - index = ix(i) - call psi_insert_dcomplex_idx_heap(key,index,l,x,ix,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ' - end if - end do - do i=n, 2, -1 - call psi_dcomplex_idx_heap_get_first(key,index,l,x,ix,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - ix(i) = index - end do - else if (.not.present(ix)) then - l = 0 - do i=1, n - key = x(i) - call psi_insert_dcomplex_heap(key,l,x,dir_,info) - if (l /= i) then - write(0,*) 'Mismatch while heapifying ! ',l,i - end if - end do - do i=n, 2, -1 - call psi_dcomplex_heap_get_first(key,l,x,dir_,info) - if (l /= i-1) then - write(0,*) 'Mismatch while pulling out of heap ',l,i - end if - x(i) = key - end do - end if - - -9999 continue - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine zhsort - - - function psb_howmany_int_heap(heap) - implicit none - type(psb_int_heap), intent(in) :: heap - integer :: psb_howmany_int_heap - psb_howmany_int_heap = heap%last - end function psb_howmany_int_heap - - subroutine psb_init_int_heap(heap,info,dir) - use psb_realloc_mod - implicit none - type(psb_int_heap), intent(inout) :: heap - integer, intent(out) :: info - integer, intent(in), optional :: dir - - info = 0 - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) - case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(0,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_sort_up_ - end select - - call psb_ensure_size(psb_heap_resize,heap%keys,info) - return - end subroutine psb_init_int_heap - - subroutine psb_dump_int_heap(iout,heap,info) - implicit none - type(psb_int_heap), intent(in) :: heap - integer, intent(out) :: info - integer, intent(in) :: iout - - info = 0 - if (iout < 0) then - write(0,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0) then - write(iout,*) heap%keys(1:heap%last) - end if - end if - end subroutine psb_dump_int_heap - - subroutine psb_insert_int_heap(key,heap,info) - use psb_realloc_mod - implicit none - - integer, intent(in) :: key - type(psb_int_heap), intent(inout) :: heap - integer, intent(out) :: info - - info = 0 - if (heap%last < 0) then - write(0,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - heap%last = heap%last - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info /= 0) then - write(0,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_insert_int_heap(key,heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_insert_int_heap - - - subroutine psb_int_heap_get_first(key,heap,info) - implicit none - - type(psb_int_heap), intent(inout) :: heap - integer, intent(out) :: key,info - - info = 0 - - call psi_int_heap_get_first(key,heap%last,heap%keys,heap%dir,info) - - return - end subroutine psb_int_heap_get_first - - - function psb_howmany_real_idx_heap(heap) - implicit none - type(psb_real_idx_heap), intent(in) :: heap - integer :: psb_howmany_real_idx_heap - psb_howmany_real_idx_heap = heap%last - end function psb_howmany_real_idx_heap - - subroutine psb_init_real_idx_heap(heap,info,dir) - use psb_realloc_mod - implicit none - type(psb_real_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - integer, intent(in), optional :: dir - - info = 0 - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) - case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(0,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_sort_up_ - end select - - call psb_ensure_size(psb_heap_resize,heap%keys,info) - call psb_ensure_size(psb_heap_resize,heap%idxs,info) - return - end subroutine psb_init_real_idx_heap - - subroutine psb_dump_real_idx_heap(iout,heap,info) - implicit none - type(psb_real_idx_heap), intent(in) :: heap - integer, intent(out) :: info - integer, intent(in) :: iout - - info = 0 - if (iout < 0) then - write(0,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) 0) then - write(iout,*) heap%keys(1:heap%last) - write(iout,*) heap%idxs(1:heap%last) - end if - end if - end subroutine psb_dump_real_idx_heap - - subroutine psb_insert_real_idx_heap(key,index,heap,info) - use psb_realloc_mod - implicit none - - real(psb_spk_), intent(in) :: key - integer, intent(in) :: index - type(psb_real_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - - info = 0 - if (heap%last < 0) then - write(0,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then - write(0,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - - call psi_insert_real_idx_heap(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_insert_real_idx_heap - - subroutine psb_real_idx_heap_get_first(key,index,heap,info) - implicit none - - type(psb_real_idx_heap), intent(inout) :: heap - integer, intent(out) :: index,info - real(psb_spk_), intent(out) :: key - - info = 0 - - call psi_real_idx_heap_get_first(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_real_idx_heap_get_first - - - function psb_howmany_double_idx_heap(heap) - implicit none - type(psb_double_idx_heap), intent(in) :: heap - integer :: psb_howmany_double_idx_heap - psb_howmany_double_idx_heap = heap%last - end function psb_howmany_double_idx_heap - - subroutine psb_init_double_idx_heap(heap,info,dir) - use psb_realloc_mod - implicit none - type(psb_double_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - integer, intent(in), optional :: dir - - info = 0 - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) - case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(0,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_sort_up_ - end select - - call psb_ensure_size(psb_heap_resize,heap%keys,info) - call psb_ensure_size(psb_heap_resize,heap%idxs,info) - return - end subroutine psb_init_double_idx_heap - - subroutine psb_dump_double_idx_heap(iout,heap,info) - implicit none - type(psb_double_idx_heap), intent(in) :: heap - integer, intent(out) :: info - integer, intent(in) :: iout - - info = 0 - if (iout < 0) then - write(0,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) 0) then - write(iout,*) heap%keys(1:heap%last) - write(iout,*) heap%idxs(1:heap%last) - end if - end if - end subroutine psb_dump_double_idx_heap - - subroutine psb_insert_double_idx_heap(key,index,heap,info) - use psb_realloc_mod - implicit none - - real(psb_dpk_), intent(in) :: key - integer, intent(in) :: index - type(psb_double_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - - info = 0 - if (heap%last < 0) then - write(0,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then - write(0,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - - call psi_insert_double_idx_heap(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_insert_double_idx_heap - - subroutine psb_double_idx_heap_get_first(key,index,heap,info) - implicit none - - type(psb_double_idx_heap), intent(inout) :: heap - integer, intent(out) :: index,info - real(psb_dpk_), intent(out) :: key - - info = 0 - - call psi_double_idx_heap_get_first(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_double_idx_heap_get_first - - function psb_howmany_int_idx_heap(heap) - implicit none - type(psb_int_idx_heap), intent(in) :: heap - integer :: psb_howmany_int_idx_heap - psb_howmany_int_idx_heap = heap%last - end function psb_howmany_int_idx_heap - - subroutine psb_init_int_idx_heap(heap,info,dir) - use psb_realloc_mod - implicit none - type(psb_int_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - integer, intent(in), optional :: dir - - info = 0 - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) - case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(0,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_sort_up_ - end select - - call psb_ensure_size(psb_heap_resize,heap%keys,info) - call psb_ensure_size(psb_heap_resize,heap%idxs,info) - return - end subroutine psb_init_int_idx_heap - - subroutine psb_dump_int_idx_heap(iout,heap,info) - implicit none - type(psb_int_idx_heap), intent(in) :: heap - integer, intent(out) :: info - integer, intent(in) :: iout - - info = 0 - if (iout < 0) then - write(0,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) 0) then - write(iout,*) heap%keys(1:heap%last) - write(iout,*) heap%idxs(1:heap%last) - end if - end if - end subroutine psb_dump_int_idx_heap - - subroutine psb_insert_int_idx_heap(key,index,heap,info) - use psb_realloc_mod - implicit none - - integer, intent(in) :: key - integer, intent(in) :: index - type(psb_int_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - - info = 0 - if (heap%last < 0) then - write(0,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then - write(0,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - - call psi_insert_int_idx_heap(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_insert_int_idx_heap - - subroutine psb_int_idx_heap_get_first(key,index,heap,info) - implicit none - - type(psb_int_idx_heap), intent(inout) :: heap - integer, intent(out) :: index,info - integer, intent(out) :: key - - info = 0 - - call psi_int_idx_heap_get_first(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_int_idx_heap_get_first - - - - function psb_howmany_scomplex_idx_heap(heap) - implicit none - type(psb_scomplex_idx_heap), intent(in) :: heap - integer :: psb_howmany_scomplex_idx_heap - psb_howmany_scomplex_idx_heap = heap%last - end function psb_howmany_scomplex_idx_heap - - subroutine psb_init_scomplex_idx_heap(heap,info,dir) - use psb_realloc_mod - implicit none - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - integer, intent(in), optional :: dir - - info = 0 - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) -!!$ case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - case (psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(0,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_asort_up_ - end select - - call psb_ensure_size(psb_heap_resize,heap%keys,info) - call psb_ensure_size(psb_heap_resize,heap%idxs,info) - return - end subroutine psb_init_scomplex_idx_heap - - subroutine psb_dump_scomplex_idx_heap(iout,heap,info) - implicit none - type(psb_scomplex_idx_heap), intent(in) :: heap - integer, intent(out) :: info - integer, intent(in) :: iout - - info = 0 - if (iout < 0) then - write(0,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) 0) then - write(iout,*) heap%keys(1:heap%last) - write(iout,*) heap%idxs(1:heap%last) - end if - end if - end subroutine psb_dump_scomplex_idx_heap - - subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) - use psb_realloc_mod - implicit none - - complex(psb_spk_), intent(in) :: key - integer, intent(in) :: index - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - - info = 0 - if (heap%last < 0) then - write(0,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then - write(0,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_insert_scomplex_idx_heap(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_insert_scomplex_idx_heap - - subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) - implicit none - - type(psb_scomplex_idx_heap), intent(inout) :: heap - integer, intent(out) :: index,info - complex(psb_spk_), intent(out) :: key - - - info = 0 - - call psi_scomplex_idx_heap_get_first(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_scomplex_idx_heap_get_first - - - - function psb_howmany_dcomplex_idx_heap(heap) - implicit none - type(psb_dcomplex_idx_heap), intent(in) :: heap - integer :: psb_howmany_dcomplex_idx_heap - psb_howmany_dcomplex_idx_heap = heap%last - end function psb_howmany_dcomplex_idx_heap - - subroutine psb_init_dcomplex_idx_heap(heap,info,dir) - use psb_realloc_mod - implicit none - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - integer, intent(in), optional :: dir - - info = 0 - heap%last=0 - if (present(dir)) then - heap%dir = dir - else - heap%dir = psb_sort_up_ - endif - select case(heap%dir) -!!$ case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) - case (psb_asort_up_,psb_asort_down_) - ! ok, do nothing - case default - write(0,*) 'Invalid direction, defaulting to psb_sort_up_' - heap%dir = psb_asort_up_ - end select - - call psb_ensure_size(psb_heap_resize,heap%keys,info) - call psb_ensure_size(psb_heap_resize,heap%idxs,info) - return - end subroutine psb_init_dcomplex_idx_heap - - subroutine psb_dump_dcomplex_idx_heap(iout,heap,info) - implicit none - type(psb_dcomplex_idx_heap), intent(in) :: heap - integer, intent(out) :: info - integer, intent(in) :: iout - - info = 0 - if (iout < 0) then - write(0,*) 'Invalid file ' - info =-1 - return - end if - - write(iout,*) 'Heap direction ',heap%dir - write(iout,*) 'Heap size ',heap%last - if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& - & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& - & (size(heap%idxs) 0) then - write(iout,*) heap%keys(1:heap%last) - write(iout,*) heap%idxs(1:heap%last) - end if - end if - end subroutine psb_dump_dcomplex_idx_heap - - subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) - use psb_realloc_mod - implicit none - - complex(psb_dpk_), intent(in) :: key - integer, intent(in) :: index - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer, intent(out) :: info - - info = 0 - if (heap%last < 0) then - write(0,*) 'Invalid last in heap ',heap%last - info = heap%last - return - endif - - call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & - & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then - write(0,*) 'Memory allocation failure in heap_insert' - info = -5 - return - end if - call psi_insert_dcomplex_idx_heap(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_insert_dcomplex_idx_heap - - subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info) - implicit none - - type(psb_dcomplex_idx_heap), intent(inout) :: heap - integer, intent(out) :: index,info - complex(psb_dpk_), intent(out) :: key - - - info = 0 - - call psi_dcomplex_idx_heap_get_first(key,index,& - & heap%last,heap%keys,heap%idxs,heap%dir,info) - - return - end subroutine psb_dcomplex_idx_heap_get_first - - - - ! - ! These are packaged so that they can be used to implement - ! a heapsort, should the need arise - ! - - - subroutine psi_insert_int_heap(key,last,heap,dir,info) - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - integer, intent(in) :: key,dir - integer, intent(inout) :: heap(:),last - integer, intent(out) :: info - integer :: i, i2 - integer :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - i = last - heap(i) = key - - select case(dir) - case (psb_sort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) < heap(i2)) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_sort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) > heap(i2)) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_int_heap - - - subroutine psi_int_heap_get_first(key,last,heap,dir,info) - implicit none - - integer, intent(inout) :: key,last - integer, intent(in) :: dir - integer, intent(inout) :: heap(:) - integer, intent(out) :: info - - integer :: i, j - integer :: temp - - - info = 0 - if (last <= 0) then - key = 0 - info = -1 - return - endif - - key = heap(1) - heap(1) = heap(last) - last = last - 1 - - select case(dir) - case (psb_sort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) < heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) > heap(j)) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_sort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) > heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) < heap(j)) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_int_heap_get_first - - - - subroutine psi_insert_real_heap(key,last,heap,dir,info) - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - real(psb_spk_), intent(in) :: key - integer, intent(in) :: dir - real(psb_spk_), intent(inout) :: heap(:) - integer, intent(inout) :: last - integer, intent(out) :: info - integer :: i, i2 - real(psb_spk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - i = last - heap(i) = key - - select case(dir) - case (psb_sort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) < heap(i2)) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_sort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) > heap(i2)) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_real_heap - - - subroutine psi_real_heap_get_first(key,last,heap,dir,info) - implicit none - - real(psb_spk_), intent(inout) :: key - integer, intent(inout) :: last - integer, intent(in) :: dir - real(psb_spk_), intent(inout) :: heap(:) - integer, intent(out) :: info - - integer :: i, j - real(psb_spk_) :: temp - - - info = 0 - if (last <= 0) then - key = 0 - info = -1 - return - endif - - key = heap(1) - heap(1) = heap(last) - last = last - 1 - - select case(dir) - case (psb_sort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) < heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) > heap(j)) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_sort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) > heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) < heap(j)) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_real_heap_get_first - - - subroutine psi_insert_double_heap(key,last,heap,dir,info) - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - real(psb_dpk_), intent(in) :: key - integer, intent(in) :: dir - real(psb_dpk_), intent(inout) :: heap(:) - integer, intent(inout) :: last - integer, intent(out) :: info - integer :: i, i2 - real(psb_dpk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - i = last - heap(i) = key - - select case(dir) - case (psb_sort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) < heap(i2)) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_sort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) > heap(i2)) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_double_heap - - - subroutine psi_double_heap_get_first(key,last,heap,dir,info) - implicit none - - real(psb_dpk_), intent(inout) :: key - integer, intent(inout) :: last - integer, intent(in) :: dir - real(psb_dpk_), intent(inout) :: heap(:) - integer, intent(out) :: info - - integer :: i, j - real(psb_dpk_) :: temp - - - info = 0 - if (last <= 0) then - key = 0 - info = -1 - return - endif - - key = heap(1) - heap(1) = heap(last) - last = last - 1 - - select case(dir) - case (psb_sort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) < heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) > heap(j)) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_sort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) > heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) < heap(j)) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_double_heap_get_first - - - - - subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - complex(psb_spk_), intent(in) :: key - integer, intent(in) :: dir - complex(psb_spk_), intent(inout) :: heap(:) - integer, intent(inout) :: last - integer, intent(out) :: info - integer :: i, i2 - complex(psb_spk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - i = last - heap(i) = key - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) < heap(i2)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) > heap(i2)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_scomplex_heap - - - subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) - implicit none - - complex(psb_spk_), intent(inout) :: key - integer, intent(inout) :: last - integer, intent(in) :: dir - complex(psb_spk_), intent(inout) :: heap(:) - integer, intent(out) :: info - - integer :: i, j - complex(psb_spk_) :: temp - - - info = 0 - if (last <= 0) then - key = 0 - info = -1 - return - endif - - key = heap(1) - heap(1) = heap(last) - last = last - 1 - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) > heap(j)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) < heap(j)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_scomplex_heap_get_first + interface + subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) + import psb_dpk_ + complex(psb_dpk_), intent(in) :: key + integer, intent(in) :: index,dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + end subroutine psi_insert_dcomplex_idx_heap + end interface + interface + subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import psb_dpk_ + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + complex(psb_dpk_), intent(out) :: key + end subroutine psi_dcomplex_idx_heap_get_first + end interface - subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) - implicit none - - ! - ! Input: - ! key: the new value - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! dir: sorting direction - - complex(psb_dpk_), intent(in) :: key - integer, intent(in) :: dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer, intent(inout) :: last - integer, intent(out) :: info - integer :: i, i2 - complex(psb_dpk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - i = last - heap(i) = key - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) < heap(i2)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) > heap(i2)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_dcomplex_heap - - - subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info) - implicit none - - complex(psb_dpk_), intent(inout) :: key - integer, intent(inout) :: last - integer, intent(in) :: dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer, intent(out) :: info - - integer :: i, j - complex(psb_dpk_) :: temp - - - info = 0 - if (last <= 0) then - key = 0 - info = -1 - return - endif - - key = heap(1) - heap(1) = heap(last) - last = last - 1 - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) > heap(j)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) < heap(j)) then -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_dcomplex_heap_get_first - - - - - subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info) - - implicit none - ! - ! Input: - ! key: the new value - ! index: the new index - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! idxs: the indices - ! dir: sorting direction - - integer, intent(in) :: key - integer, intent(in) :: index,dir - integer, intent(inout) :: heap(:),last - integer, intent(inout) :: idxs(:) - integer, intent(out) :: info - integer :: i, i2, itemp - integer :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - - i = last - heap(i) = key - idxs(i) = index - - select case(dir) - case (psb_sort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) < heap(i2)) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_sort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) > heap(i2)) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_int_idx_heap - - subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - implicit none - - integer, intent(inout) :: heap(:) - integer, intent(out) :: index,info - integer, intent(inout) :: last,idxs(:) - integer, intent(in) :: dir - integer, intent(out) :: key - - integer :: i, j,itemp - integer :: temp - - info = 0 - if (last <= 0) then - key = 0 - index = 0 - info = -1 - return - endif - - key = heap(1) - index = idxs(1) - heap(1) = heap(last) - idxs(1) = idxs(last) - last = last - 1 - - select case(dir) - case (psb_sort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) < heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) > heap(j)) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_sort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) > heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) < heap(j)) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_int_idx_heap_get_first - - subroutine psi_insert_real_idx_heap(key,index,last,heap,idxs,dir,info) - - implicit none - ! - ! Input: - ! key: the new value - ! index: the new index - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! idxs: the indices - ! dir: sorting direction - - real(psb_spk_), intent(in) :: key - integer, intent(in) :: index,dir - real(psb_spk_), intent(inout) :: heap(:) - integer, intent(inout) :: idxs(:),last - integer, intent(out) :: info - integer :: i, i2, itemp - real(psb_spk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - - i = last - heap(i) = key - idxs(i) = index - - select case(dir) - case (psb_sort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) < heap(i2)) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_sort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) > heap(i2)) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_real_idx_heap - - subroutine psi_real_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - implicit none - - real(psb_spk_), intent(inout) :: heap(:) - integer, intent(out) :: index,info - integer, intent(inout) :: last,idxs(:) - integer, intent(in) :: dir - real(psb_spk_), intent(out) :: key - - integer :: i, j,itemp - real(psb_spk_) :: temp - - info = 0 - if (last <= 0) then - key = 0 - index = 0 - info = -1 - return - endif - - key = heap(1) - index = idxs(1) - heap(1) = heap(last) - idxs(1) = idxs(last) - last = last - 1 - - select case(dir) - case (psb_sort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) < heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) > heap(j)) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_sort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) > heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) < heap(j)) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_real_idx_heap_get_first - - - subroutine psi_insert_double_idx_heap(key,index,last,heap,idxs,dir,info) - - implicit none - ! - ! Input: - ! key: the new value - ! index: the new index - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! idxs: the indices - ! dir: sorting direction - - real(psb_dpk_), intent(in) :: key - integer, intent(in) :: index,dir - real(psb_dpk_), intent(inout) :: heap(:) - integer, intent(inout) :: idxs(:),last - integer, intent(out) :: info - integer :: i, i2, itemp - real(psb_dpk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - - i = last - heap(i) = key - idxs(i) = index - - select case(dir) - case (psb_sort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) < heap(i2)) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_sort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (heap(i) > heap(i2)) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_double_idx_heap - - subroutine psi_double_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - implicit none - - real(psb_dpk_), intent(inout) :: heap(:) - integer, intent(out) :: index,info - integer, intent(inout) :: last,idxs(:) - integer, intent(in) :: dir - real(psb_dpk_), intent(out) :: key - - integer :: i, j,itemp - real(psb_dpk_) :: temp - - info = 0 - if (last <= 0) then - key = 0 - index = 0 - info = -1 - return - endif - - key = heap(1) - index = idxs(1) - heap(1) = heap(last) - idxs(1) = idxs(last) - last = last - 1 - - select case(dir) - case (psb_sort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) < heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) > heap(j)) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_sort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (heap(2*i) > heap(2*i+1)) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (heap(i) < heap(j)) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_double_idx_heap_get_first - - - subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) - - implicit none - ! - ! Input: - ! key: the new value - ! index: the new index - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! idxs: the indices - ! dir: sorting direction - - complex(psb_spk_), intent(in) :: key - integer, intent(in) :: index,dir - complex(psb_spk_), intent(inout) :: heap(:) - integer, intent(inout) :: idxs(:),last - integer, intent(out) :: info - integer :: i, i2, itemp - complex(psb_spk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - - i = last - heap(i) = key - idxs(i) = index - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) < heap(i2)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(i2) -!!$ idxs(i2) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) > heap(i2)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(i2) -!!$ idxs(i2) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_scomplex_idx_heap - - subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - implicit none - - complex(psb_spk_), intent(inout) :: heap(:) - integer, intent(out) :: index,info - integer, intent(inout) :: last,idxs(:) - integer, intent(in) :: dir - complex(psb_spk_), intent(out) :: key - - integer :: i, j, itemp - complex(psb_spk_) :: temp - - info = 0 - if (last <= 0) then - key = 0 - index = 0 - info = -1 - return - endif - - key = heap(1) - index = idxs(1) - heap(1) = heap(last) - idxs(1) = idxs(last) - last = last - 1 - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) > heap(j)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(j) -!!$ idxs(j) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) < heap(j)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(j) -!!$ idxs(j) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_scomplex_idx_heap_get_first - - - subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) - - implicit none - ! - ! Input: - ! key: the new value - ! index: the new index - ! last: pointer to the last occupied element in heap - ! heap: the heap - ! idxs: the indices - ! dir: sorting direction - - complex(psb_dpk_), intent(in) :: key - integer, intent(in) :: index,dir - complex(psb_dpk_), intent(inout) :: heap(:) - integer, intent(inout) :: idxs(:),last - integer, intent(out) :: info - integer :: i, i2, itemp - complex(psb_dpk_) :: temp - - info = 0 - if (last < 0) then - write(0,*) 'Invalid last in heap ',last - info = last - return - endif - - last = last + 1 - if (last > size(heap)) then - write(0,*) 'out of bounds ' - info = -1 - return - end if - - i = last - heap(i) = key - idxs(i) = index - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) < heap(i2)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(i2) -!!$ idxs(i2) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ do -!!$ if (i<=1) exit -!!$ i2 = i/2 -!!$ if (heap(i) > heap(i2)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(i2) -!!$ idxs(i2) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(i2) -!!$ heap(i2) = temp -!!$ i = i2 -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) < abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case (psb_asort_down_) - - do - if (i<=1) exit - i2 = i/2 - if (abs(heap(i)) > abs(heap(i2))) then - itemp = idxs(i) - idxs(i) = idxs(i2) - idxs(i2) = itemp - temp = heap(i) - heap(i) = heap(i2) - heap(i2) = temp - i = i2 - else - exit - end if - end do - - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_insert_dcomplex_idx_heap - - subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - implicit none - - complex(psb_dpk_), intent(inout) :: heap(:) - integer, intent(out) :: index,info - integer, intent(inout) :: last,idxs(:) - integer, intent(in) :: dir - complex(psb_dpk_), intent(out) :: key - - integer :: i, j, itemp - complex(psb_dpk_) :: temp - - info = 0 - if (last <= 0) then - key = 0 - index = 0 - info = -1 - return - endif - - key = heap(1) - index = idxs(1) - heap(1) = heap(last) - idxs(1) = idxs(last) - last = last - 1 - - select case(dir) -!!$ case (psb_sort_up_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) > heap(j)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(j) -!!$ idxs(j) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ -!!$ case (psb_sort_down_) -!!$ -!!$ i = 1 -!!$ do -!!$ if (i > (last/2)) exit -!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& -!!$ & (2*i == last)) then -!!$ j = 2*i -!!$ else -!!$ j = 2*i + 1 -!!$ end if -!!$ -!!$ if (heap(i) < heap(j)) then -!!$ itemp = idxs(i) -!!$ idxs(i) = idxs(j) -!!$ idxs(j) = itemp -!!$ temp = heap(i) -!!$ heap(i) = heap(j) -!!$ heap(j) = temp -!!$ i = j -!!$ else -!!$ exit -!!$ end if -!!$ end do - - case (psb_asort_up_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) > abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - - case (psb_asort_down_) - - i = 1 - do - if (i > (last/2)) exit - if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& - & (2*i == last)) then - j = 2*i - else - j = 2*i + 1 - end if - - if (abs(heap(i)) < abs(heap(j))) then - itemp = idxs(i) - idxs(i) = idxs(j) - idxs(j) = itemp - temp = heap(i) - heap(i) = heap(j) - heap(j) = temp - i = j - else - exit - end if - end do - - case default - write(0,*) 'Invalid direction in heap ',dir - end select - - return - end subroutine psi_dcomplex_idx_heap_get_first - - end module psb_sort_mod diff --git a/base/modules/psb_z_base_mat_mod.f03 b/base/modules/psb_z_base_mat_mod.f03 index 79393f05..46c9f138 100644 --- a/base/modules/psb_z_base_mat_mod.f03 +++ b/base/modules/psb_z_base_mat_mod.f03 @@ -1,54 +1,52 @@ module psb_z_base_mat_mod use psb_base_mat_mod - + type, extends(psb_base_sparse_mat) :: psb_z_base_sparse_mat contains - procedure, pass(a) :: z_base_csmv - procedure, pass(a) :: z_base_csmm - generic, public :: csmm => z_base_csmm, z_base_csmv - procedure, pass(a) :: z_base_cssv - procedure, pass(a) :: z_base_cssm - generic, public :: base_cssm => z_base_cssm, z_base_cssv - procedure, pass(a) :: z_cssv - procedure, pass(a) :: z_cssm - generic, public :: cssm => z_cssm, z_cssv - procedure, pass(a) :: z_scals - procedure, pass(a) :: z_scal - generic, public :: scal => z_scals, z_scal - procedure, pass(a) :: csnmi - procedure, pass(a) :: get_diag - procedure, pass(a) :: csput - - procedure, pass(a) :: z_csgetrow - procedure, pass(a) :: z_csgetblk - generic, public :: csget => z_csgetrow, z_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: cp_to_coo - procedure, pass(a) :: cp_from_coo - procedure, pass(a) :: cp_to_fmt - procedure, pass(a) :: cp_from_fmt - procedure, pass(a) :: mv_to_coo - procedure, pass(a) :: mv_from_coo - procedure, pass(a) :: mv_to_fmt - procedure, pass(a) :: mv_from_fmt + procedure, pass(a) :: z_csmv => psb_z_base_csmv + procedure, pass(a) :: z_csmm => psb_z_base_csmm + generic, public :: csmm => z_csmm, z_csmv + procedure, pass(a) :: z_inner_cssv => psb_z_base_inner_cssv + procedure, pass(a) :: z_inner_cssm => psb_z_base_inner_cssm + generic, public :: inner_cssm => z_inner_cssm, z_inner_cssv + procedure, pass(a) :: z_cssv => psb_z_base_cssv + procedure, pass(a) :: z_cssm => psb_z_base_cssm + generic, public :: cssm => z_cssm, z_cssv + procedure, pass(a) :: z_scals => psb_z_base_scals + procedure, pass(a) :: z_scal => psb_z_base_scal + generic, public :: scal => z_scals, z_scal + procedure, pass(a) :: csnmi => psb_z_base_csnmi + procedure, pass(a) :: get_diag => psb_z_base_get_diag + + procedure, pass(a) :: csput => psb_z_base_csput + procedure, pass(a) :: z_csgetrow => psb_z_base_csgetrow + procedure, pass(a) :: z_csgetblk => psb_z_base_csgetblk + generic, public :: csget => z_csgetrow, z_csgetblk + procedure, pass(a) :: csclip => psb_z_base_csclip + procedure, pass(a) :: cp_to_coo => psb_z_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_z_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_z_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_z_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_z_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_z_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_z_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_z_base_mv_from_fmt procedure, pass(a) :: z_base_cp_from generic, public :: cp_from => z_base_cp_from procedure, pass(a) :: z_base_mv_from generic, public :: mv_from => z_base_mv_from - - procedure, pass(a) :: base_transp_1mat => z_base_transp_1mat - procedure, pass(a) :: base_transp_2mat => z_base_transp_2mat - procedure, pass(a) :: base_transc_1mat => z_base_transc_1mat - procedure, pass(a) :: base_transc_2mat => z_base_transc_2mat + + procedure, pass(a) :: transp_1mat => psb_z_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_z_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_z_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_z_base_transc_2mat + end type psb_z_base_sparse_mat - - private :: z_base_csmv, z_base_csmm, z_base_cssv, z_base_cssm,& - & z_scals, z_scal, csnmi, csput, z_csgetrow, z_csgetblk, & - & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & - & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & - & get_diag, csclip, z_cssv, z_cssm, base_cp_from, base_mv_from - + + private :: z_base_cssv, z_base_cssm, z_base_cp_from, z_base_mv_from + + type, extends(psb_z_base_sparse_mat) :: psb_z_coo_sparse_mat integer :: nnz @@ -57,180 +55,511 @@ module psb_z_base_mat_mod contains - procedure, pass(a) :: get_size => z_coo_get_size - procedure, pass(a) :: get_nzeros => z_coo_get_nzeros - procedure, pass(a) :: set_nzeros => z_coo_set_nzeros - procedure, pass(a) :: z_base_csmm => z_coo_csmm - procedure, pass(a) :: z_base_csmv => z_coo_csmv - procedure, pass(a) :: z_base_cssm => z_coo_cssm - procedure, pass(a) :: z_base_cssv => z_coo_cssv - procedure, pass(a) :: z_scals => z_coo_scals - procedure, pass(a) :: z_scal => z_coo_scal - procedure, pass(a) :: csnmi => z_coo_csnmi - procedure, pass(a) :: csput => z_coo_csput - procedure, pass(a) :: get_diag => z_coo_get_diag - procedure, pass(a) :: reallocate_nz => z_coo_reallocate_nz - procedure, pass(a) :: allocate_mnnz => z_coo_allocate_mnnz - procedure, pass(a) :: cp_to_coo => z_cp_coo_to_coo - procedure, pass(a) :: cp_from_coo => z_cp_coo_from_coo - procedure, pass(a) :: cp_to_fmt => z_cp_coo_to_fmt - procedure, pass(a) :: cp_from_fmt => z_cp_coo_from_fmt - procedure, pass(a) :: mv_to_coo => z_mv_coo_to_coo - procedure, pass(a) :: mv_from_coo => z_mv_coo_from_coo - procedure, pass(a) :: mv_to_fmt => z_mv_coo_to_fmt - procedure, pass(a) :: mv_from_fmt => z_mv_coo_from_fmt - procedure, pass(a) :: fix => z_fix_coo - procedure, pass(a) :: free => z_coo_free - procedure, pass(a) :: trim => z_coo_trim - procedure, pass(a) :: z_csgetrow => z_coo_csgetrow - procedure, pass(a) :: csgetptn => z_coo_csgetptn - procedure, pass(a) :: print => z_coo_print - procedure, pass(a) :: get_fmt => z_coo_get_fmt - procedure, pass(a) :: get_nz_row => z_coo_get_nz_row - procedure, pass(a) :: sizeof => z_coo_sizeof - procedure, pass(a) :: reinit => z_coo_reinit - procedure, pass(a) :: z_coo_cp_from - generic, public :: cp_from => z_coo_cp_from - procedure, pass(a) :: z_coo_mv_from - generic, public :: mv_from => z_coo_mv_from - procedure, pass(a) :: base_transp_1mat => z_coo_transp_1mat - procedure, pass(a) :: base_transc_1mat => z_coo_transc_1mat + procedure, pass(a) :: get_size => z_coo_get_size + procedure, pass(a) :: get_nzeros => z_coo_get_nzeros + procedure, pass(a) :: set_nzeros => z_coo_set_nzeros + procedure, pass(a) :: get_fmt => z_coo_get_fmt + procedure, pass(a) :: sizeof => z_coo_sizeof + procedure, pass(a) :: z_csmm => psb_z_coo_csmm + procedure, pass(a) :: z_csmv => psb_z_coo_csmv + procedure, pass(a) :: z_inner_cssm => psb_z_coo_cssm + procedure, pass(a) :: z_inner_cssv => psb_z_coo_cssv + procedure, pass(a) :: z_scals => psb_z_coo_scals + procedure, pass(a) :: z_scal => psb_z_coo_scal + procedure, pass(a) :: csnmi => psb_z_coo_csnmi + procedure, pass(a) :: reallocate_nz => psb_z_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_z_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_z_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_z_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_z_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_z_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_z_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_z_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_z_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_z_mv_coo_from_fmt + procedure, pass(a) :: csput => psb_z_coo_csput + procedure, pass(a) :: get_diag => psb_z_coo_get_diag + procedure, pass(a) :: z_csgetrow => psb_z_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_z_coo_csgetptn + procedure, pass(a) :: get_nz_row => psb_z_coo_get_nz_row + procedure, pass(a) :: reinit => psb_z_coo_reinit + procedure, pass(a) :: fix => psb_z_fix_coo + procedure, pass(a) :: trim => psb_z_coo_trim + procedure, pass(a) :: print => psb_z_coo_print + procedure, pass(a) :: free => z_coo_free + procedure, pass(a) :: psb_z_coo_cp_from + generic, public :: cp_from => psb_z_coo_cp_from + procedure, pass(a) :: psb_z_coo_mv_from + generic, public :: mv_from => psb_z_coo_mv_from + procedure, pass(a) :: transp_1mat => z_coo_transp_1mat + procedure, pass(a) :: transc_1mat => z_coo_transc_1mat end type psb_z_coo_sparse_mat - - private :: z_coo_get_nzeros, z_coo_set_nzeros, z_coo_get_diag, & - & z_coo_csmm, z_coo_csmv, z_coo_cssm, z_coo_cssv, z_coo_csnmi, & - & z_coo_csput, z_coo_reallocate_nz, z_coo_allocate_mnnz, & - & z_fix_coo, z_coo_free, z_coo_print, z_coo_get_fmt, & - & z_cp_coo_to_coo, z_cp_coo_from_coo, & - & z_cp_coo_to_fmt, z_cp_coo_from_fmt, & - & z_coo_scals, z_coo_scal, z_coo_csgetrow, z_coo_sizeof, & - & z_coo_csgetptn, z_coo_get_nz_row, z_coo_reinit,& - & z_coo_cp_from, z_coo_mv_from, & + + private :: z_coo_get_nzeros, z_coo_set_nzeros, & + & z_coo_get_fmt, z_coo_free, z_coo_sizeof, & & z_coo_transp_1mat, z_coo_transc_1mat - + + + + !=================== + ! + ! BASE interfaces + ! + !=================== + + + interface + subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_base_csmm + end interface + + interface + subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_base_csmv + end interface + + interface + subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_base_inner_cssm + end interface + + interface + subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_base_inner_cssv + end interface + + interface + subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_z_base_cssm + end interface + + interface + subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_z_base_cssv + end interface + + interface + subroutine psb_z_base_scals(d,a,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_z_base_scals + end interface + + interface + subroutine psb_z_base_scal(d,a,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_base_scal + end interface + + interface + function psb_z_base_csnmi(a) result(res) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_z_base_csnmi + end interface + + interface + subroutine psb_z_base_get_diag(a,d,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_base_get_diag + end interface + + interface + subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_z_base_csput + end interface + + interface + subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_base_csgetrow + end interface + + interface + subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_base_csgetblk + end interface + + + interface + subroutine psb_z_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_base_csclip + end interface + + + interface + subroutine psb_z_base_cp_to_coo(a,b,info) + import psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_base_cp_to_coo + end interface + + interface + subroutine psb_z_base_cp_from_coo(a,b,info) + import psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_z_base_cp_from_coo + end interface + + interface + subroutine psb_z_base_cp_to_fmt(a,b,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_base_cp_to_fmt + end interface + + interface + subroutine psb_z_base_cp_from_fmt(a,b,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_z_base_cp_from_fmt + end interface + + interface + subroutine psb_z_base_mv_to_coo(a,b,info) + import psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_base_mv_to_coo + end interface + + interface + subroutine psb_z_base_mv_from_coo(a,b,info) + import psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_base_mv_from_coo + end interface + + interface + subroutine psb_z_base_mv_to_fmt(a,b,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_base_mv_to_fmt + end interface + + interface + subroutine psb_z_base_mv_from_fmt(a,b,info) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_base_mv_from_fmt + end interface + + interface + subroutine psb_z_base_transp_2mat(a,b) + import psb_z_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_z_base_transp_2mat + end interface + + interface + subroutine psb_z_base_transc_2mat(a,b) + import psb_z_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + end subroutine psb_z_base_transc_2mat + end interface + + interface + subroutine psb_z_base_transp_1mat(a) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + end subroutine psb_z_base_transp_1mat + end interface + + interface + subroutine psb_z_base_transc_1mat(a) + import psb_z_base_sparse_mat, psb_dpk_ + class(psb_z_base_sparse_mat), intent(inout) :: a + end subroutine psb_z_base_transc_1mat + end interface + + + + + !================= + ! + ! COO interfaces + ! + !================= + + interface + subroutine psb_z_coo_reallocate_nz(nz,a) + import psb_z_coo_sparse_mat + integer, intent(in) :: nz + class(psb_z_coo_sparse_mat), intent(inout) :: a + end subroutine psb_z_coo_reallocate_nz + end interface + + interface + subroutine psb_z_coo_reinit(a,clear) + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_z_coo_reinit + end interface + + interface + subroutine psb_z_coo_trim(a) + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + end subroutine psb_z_coo_trim + end interface + + interface + subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) + import psb_z_coo_sparse_mat + integer, intent(in) :: m,n + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_z_coo_allocate_mnnz + end interface + + interface + subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_z_coo_sparse_mat + integer, intent(in) :: iout + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_z_coo_print + end interface + + + interface + function psb_z_coo_get_nz_row(idx,a) result(res) + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + end function psb_z_coo_get_nz_row + end interface + interface - subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) - use psb_const_mod + subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + import psb_dpk_ integer, intent(in) :: nzin,dupl integer, intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) integer, intent(out) :: nzout, info integer, intent(in), optional :: idir - end subroutine z_fix_coo_inner + end subroutine psb_z_fix_coo_inner end interface - + interface - subroutine z_fix_coo_impl(a,info,idir) - use psb_const_mod + subroutine psb_z_fix_coo(a,info,idir) import psb_z_coo_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a integer, intent(out) :: info integer, intent(in), optional :: idir - end subroutine z_fix_coo_impl + end subroutine psb_z_fix_coo end interface - + interface - subroutine z_cp_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_z_cp_coo_to_coo(a,b,info) import psb_z_coo_sparse_mat class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_cp_coo_to_coo_impl + end subroutine psb_z_cp_coo_to_coo end interface interface - subroutine z_cp_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_z_cp_coo_from_coo(a,b,info) import psb_z_coo_sparse_mat - class(psb_z_coo_sparse_mat), intent(out) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine z_cp_coo_from_coo_impl + end subroutine psb_z_cp_coo_from_coo end interface - + interface - subroutine z_cp_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_z_cp_coo_to_fmt(a,b,info) import psb_z_coo_sparse_mat, psb_z_base_sparse_mat class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_cp_coo_to_fmt_impl + end subroutine psb_z_cp_coo_to_fmt end interface - + interface - subroutine z_cp_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_z_cp_coo_from_fmt(a,b,info) import psb_z_coo_sparse_mat, psb_z_base_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine z_cp_coo_from_fmt_impl + end subroutine psb_z_cp_coo_from_fmt end interface - + interface - subroutine z_mv_coo_to_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_z_mv_coo_to_coo(a,b,info) import psb_z_coo_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_coo_to_coo_impl + end subroutine psb_z_mv_coo_to_coo end interface - + interface - subroutine z_mv_coo_from_coo_impl(a,b,info) - use psb_const_mod + subroutine psb_z_mv_coo_from_coo(a,b,info) import psb_z_coo_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_coo_from_coo_impl + end subroutine psb_z_mv_coo_from_coo end interface - + interface - subroutine z_mv_coo_to_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_z_mv_coo_to_fmt(a,b,info) import psb_z_coo_sparse_mat, psb_z_base_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_coo_to_fmt_impl + end subroutine psb_z_mv_coo_to_fmt end interface - + interface - subroutine z_mv_coo_from_fmt_impl(a,b,info) - use psb_const_mod + subroutine psb_z_mv_coo_from_fmt(a,b,info) import psb_z_coo_sparse_mat, psb_z_base_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_coo_from_fmt_impl + end subroutine psb_z_mv_coo_from_fmt end interface - - + interface - subroutine z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_z_coo_sparse_mat + subroutine psb_z_coo_cp_from(a,b) + import psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_coo_sparse_mat), intent(inout) :: a + type(psb_z_coo_sparse_mat), intent(in) :: b + end subroutine psb_z_coo_cp_from + end interface + + interface + subroutine psb_z_coo_mv_from(a,b) + import psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_coo_sparse_mat), intent(inout) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: b + end subroutine psb_z_coo_mv_from + end interface + + + interface + subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer, intent(in) :: nz,ia(:), ja(:),& & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine z_coo_csput_impl + end subroutine psb_z_coo_csput end interface - + interface - subroutine z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_z_coo_sparse_mat - implicit none + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -240,16 +569,13 @@ module psb_z_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine z_coo_csgetptn_impl + end subroutine psb_z_coo_csgetptn end interface interface - subroutine z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_z_coo_sparse_mat - implicit none - + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -260,1206 +586,117 @@ module psb_z_base_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine z_coo_csgetrow_impl + end subroutine psb_z_coo_csgetrow end interface - interface z_coo_cssm_impl - subroutine z_coo_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_coo_sparse_mat + interface + subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_coo_cssv_impl - subroutine z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_coo_sparse_mat + end subroutine psb_z_coo_cssv + subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_coo_cssm_impl + end subroutine psb_z_coo_cssm end interface - - interface z_coo_csmm_impl - subroutine z_coo_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_coo_sparse_mat + + interface + subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_coo_csmv_impl - subroutine z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_coo_sparse_mat + end subroutine psb_z_coo_csmv + subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_coo_csmm_impl + end subroutine psb_z_coo_csmm end interface - - - interface z_coo_csnmi_impl - function z_coo_csnmi_impl(a) result(res) - use psb_const_mod - import psb_z_coo_sparse_mat + + + interface + function psb_z_coo_csnmi(a) result(res) + import psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function z_coo_csnmi_impl + end function psb_z_coo_csnmi end interface - - + + interface + subroutine psb_z_coo_get_diag(a,d,info) + import psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_coo_get_diag + end interface + + interface + subroutine psb_z_coo_scal(d,a,info) + import psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_coo_scal + end interface + + interface + subroutine psb_z_coo_scals(d,a,info) + import psb_z_coo_sparse_mat, psb_dpk_ + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_z_coo_scals + end interface + + contains - - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - subroutine cp_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_coo - - subroutine cp_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_coo - - - subroutine cp_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_to_fmt - - subroutine cp_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine cp_from_fmt - - - subroutine mv_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_coo - - subroutine mv_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_coo - - - subroutine mv_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_to_fmt - - subroutine mv_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine mv_from_fmt - + + subroutine z_base_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_base_sparse_mat), intent(out) :: a - type(psb_z_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine z_base_mv_from - - subroutine z_base_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_base_sparse_mat), intent(out) :: a - type(psb_z_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine z_base_cp_from - - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine csput - - subroutine z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_base_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_csgetrow - - - - subroutine z_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csgetblk - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csclip - - - ! - ! Here we go. - ! - subroutine z_coo_transp_1mat(a) - use psb_error_mod - implicit none - - class(psb_z_coo_sparse_mat), intent(inout) :: a - - integer, allocatable :: itemp(:) - integer :: info - call a%psb_z_base_sparse_mat%psb_base_sparse_mat%transp() - call move_alloc(a%ia,itemp) - call move_alloc(a%ja,a%ia) - call move_alloc(itemp,a%ja) - - call a%fix(info) - - return - - end subroutine z_coo_transp_1mat - - subroutine z_coo_transc_1mat(a) - use psb_error_mod implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: a + type(psb_z_base_sparse_mat), intent(inout) :: b - call a%transp() - a%val(:) = conjg(a%val) - - end subroutine z_coo_transc_1mat - - subroutine z_base_transp_2mat(a,b) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - type(psb_z_coo_sparse_mat) :: tmp - integer err_act, info - character(len=*), parameter :: name='z_base_transp' + ! No new things here, very easy + call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - call psb_erractionsave(err_act) - - info = 0 - select type(b) - class is (psb_z_base_sparse_mat) - call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - class default - info = 700 - end select - if (info /= 0) then - call psb_errpush(info,name,a_err=b%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - end subroutine z_base_transp_2mat - - subroutine z_base_transc_2mat(a,b) - use psb_error_mod + end subroutine z_base_mv_from + + subroutine z_base_cp_from(a,b) implicit none class(psb_z_base_sparse_mat), intent(out) :: a - class(psb_base_sparse_mat), intent(in) :: b - - type(psb_z_coo_sparse_mat) :: tmp - integer err_act, info - character(len=*), parameter :: name='z_base_transc' - - call psb_erractionsave(err_act) - - - info = 0 - select type(b) - class is (psb_z_base_sparse_mat) - call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transc() - if (info == 0) call a%mv_from_coo(tmp,info) - class default - info = 700 - end select - if (info /= 0) then - call psb_errpush(info,name,a_err=b%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - end subroutine z_base_transc_2mat - - subroutine z_base_transp_1mat(a) - use psb_error_mod - implicit none - - class(psb_z_base_sparse_mat), intent(inout) :: a - - type(psb_z_coo_sparse_mat) :: tmp - integer :: err_act, info - character(len=*), parameter :: name='z_base_transp' - - call psb_erractionsave(err_act) - info = 0 - call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) - - if (info /= 0) then - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - - - end subroutine z_base_transp_1mat - - subroutine z_base_transc_1mat(a) - use psb_error_mod - implicit none - - class(psb_z_base_sparse_mat), intent(inout) :: a - - type(psb_z_coo_sparse_mat) :: tmp - integer :: err_act, info - character(len=*), parameter :: name='z_base_transc' - - call psb_erractionsave(err_act) - info = 0 - call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transc() - if (info == 0) call a%mv_from_coo(tmp,info) - - if (info /= 0) then - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - goto 9999 - end if - call psb_erractionrestore(err_act) - - return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return - - - end subroutine z_base_transc_1mat - - - - - - !==================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !==================================== - - subroutine z_base_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_base_csmm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_base_csmm - - subroutine z_base_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_base_csmv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine z_base_csmv - - subroutine z_base_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_base_cssm' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_base_cssm - - subroutine z_base_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_base_cssv' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_base_cssv - - subroutine z_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - - complex(psb_dpk_), allocatable :: tmp(:,:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='z_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = min(size(x,2), size(y,2)) - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then - do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) - end do - end if - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(zone,x,zzero,tmp,info,trans) - - if (info == 0)then - do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) - end do - end if - if (info == 0)& - & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine z_cssm - - subroutine z_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - - complex(psb_dpk_), allocatable :: tmp(:) - Integer :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - character(len=20) :: name='z_cssm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - nc = 1 - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - if (present(d)) then - if (present(scale)) then - scale_ = scale - else - scale_ = 'L' - end if - - if (psb_toupper(scale_) == 'R') then - if (size(d,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) tmp(1:nac) = d(1:nac)*x(1:nac) - if (info == 0)& - & call a%base_cssm(alpha,tmp,beta,y,info,trans) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else if (psb_toupper(scale_) == 'L') then - if (size(d,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) - goto 9999 - end if - - allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& - & call a%base_cssm(zone,x,zzero,tmp,info,trans) - - if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar) - if (info == 0)& - & call psb_geaxpby(nar,alpha,tmp,beta,y,info) - - if (info == 0) then - deallocate(tmp,stat=info) - if (info /= 0) info = 4000 - end if - - else - info = 31 - call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) - goto 9999 - end if - else - ! Scale is ignored in this case - call a%base_cssm(alpha,x,beta,y,info,trans) - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name, a_err='base_cssm') - goto 9999 - end if - - - return - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine z_cssv - - - subroutine z_scals(d,a,info) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='z_scals' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_scals - - - subroutine z_scal(d,a,info) - use psb_error_mod - implicit none - class(psb_z_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='z_scal' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_scal - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = -done - - return - - end function csnmi - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = 700 - call psb_errpush(info,name,a_err=a%get_fmt()) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - + type(psb_z_base_sparse_mat), intent(in) :: b + + ! No new things here, very easy + call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) + return - - end subroutine get_diag - - - - + + end subroutine z_base_cp_from + + + !==================================== ! ! @@ -1471,35 +708,35 @@ contains ! ! !==================================== - - + + function z_coo_sizeof(a) result(res) implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 + 1 - res = res + 2*psb_sizeof_dp * size(a%val) + res = res + 2 * psb_sizeof_dp * size(a%val) res = res + psb_sizeof_int * size(a%ia) res = res + psb_sizeof_int * size(a%ja) - + end function z_coo_sizeof - - + + function z_coo_get_fmt(a) result(res) implicit none class(psb_z_coo_sparse_mat), intent(in) :: a character(len=5) :: res res = 'COO' end function z_coo_get_fmt - - + + function z_coo_get_size(a) result(res) implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) if (allocated(a%ja)) then if (res >= 0) then @@ -1516,66 +753,16 @@ contains end if end if end function z_coo_get_size - - + + function z_coo_get_nzeros(a) result(res) implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer :: res res = a%nnz end function z_coo_get_nzeros - - - function z_coo_get_nz_row(idx,a) result(res) - use psb_const_mod - use psb_sort_mod - implicit none - - class(psb_z_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer :: res - integer :: nzin_, nza,ip,jp,i,k - - res = 0 - nza = a%get_nzeros() - if (a%is_sorted()) then - ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) - if (ip /= -1) return - jp = ip - do - if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else - exit - end if - end do - do - if (jp == nza) exit - if (a%ia(jp+1) == idx) then - jp = jp + 1 - else - exit - end if - end do - - res = jp - ip +1 - - else - - res = 0 - - do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 - end if - end do - - end if - - end function z_coo_get_nz_row - + + !==================================== ! ! @@ -1588,807 +775,49 @@ contains ! ! !==================================== - + subroutine z_coo_set_nzeros(nz,a) - implicit none - integer, intent(in) :: nz - class(psb_z_coo_sparse_mat), intent(inout) :: a - - a%nnz = nz - - end subroutine z_coo_set_nzeros - - !==================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !==================================== - - - subroutine z_fix_coo(a,info,idir) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: idir - Integer :: err_act - character(len=20) :: name='fix_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_fix_coo_impl(a,info,idir) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - - end subroutine z_fix_coo - - - subroutine z_cp_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_coo_to_coo - - subroutine z_cp_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(out) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_coo_from_coo - - - subroutine z_cp_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_coo_to_fmt - - subroutine z_cp_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_coo_from_fmt - - - - subroutine z_mv_coo_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_coo_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_coo_to_coo - - subroutine z_mv_coo_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_coo_from_coo - - - - subroutine z_coo_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_coo_sparse_mat), intent(out) :: a - type(psb_z_coo_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_coo_cp_from - - subroutine z_coo_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_coo_sparse_mat), intent(out) :: a - type(psb_z_coo_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_coo_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_coo_mv_from - - - subroutine z_mv_coo_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_coo_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_coo_to_fmt - - subroutine z_mv_coo_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_coo_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_coo_from_fmt - - - - subroutine z_coo_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_z_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='z_coo_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,a%ja,a%val,info) - - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_reallocate_nz - - - subroutine z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='z_coo_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - nza = a%get_nzeros() - call z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_csput - - - subroutine z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + implicit none + integer, intent(in) :: nz + class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_csgetrow - - - subroutine z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none + a%nnz = nz - class(psb_z_coo_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_csgetptn - - + end subroutine z_coo_set_nzeros + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + + subroutine z_coo_free(a) implicit none - + class(psb_z_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() call a%set_nrows(0) call a%set_ncols(0) - + call a%set_nzeros(0) + return - + end subroutine z_coo_free - - subroutine z_coo_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_z_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = zzero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_reinit - - - subroutine z_coo_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_trim - - subroutine z_coo_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_z_coo_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_nzeros(0) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - call a%set_dupl(psb_dupl_def_) - end if - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_allocate_mnnz - - - subroutine z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_z_coo_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='z_coo_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do j=1,a%get_nzeros() - write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) - enddo - else if (present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do j=1,a%get_nzeros() - write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) - enddo - endif - endif - - end subroutine z_coo_print - - - - + + + !==================================== ! ! @@ -2401,381 +830,36 @@ contains ! ! !==================================== - - subroutine z_coo_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod + subroutine z_coo_transp_1mat(a) implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nac, nar - complex(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='z_coo_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if - - call z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_csmv - - subroutine z_coo_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - complex(psb_dpk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='z_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + class(psb_z_coo_sparse_mat), intent(inout) :: a - call z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_csmm - - - subroutine z_coo_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nar, nac - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='z_coo_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + integer, allocatable :: itemp(:) + integer :: info - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine z_coo_cssv - - - - subroutine z_coo_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='z_coo_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - nar = a%get_nrows() - nac = a%get_ncols() - if (size(x,1) < nac) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) - goto 9999 - end if - if (size(y,1) < nar) then - info = 36 - call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) - goto 9999 - end if + call a%psb_z_base_sparse_mat%psb_base_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%fix(info) - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_cssm - - function z_coo_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = z_coo_csnmi_impl(a) - - return - - end function z_coo_csnmi - - subroutine z_coo_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = zzero - - do i=1,a%get_nzeros() - j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then - d(j) = a%val(i) - endif - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_coo_get_diag - - subroutine z_coo_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1,a%get_nzeros() - j = a%ia(i) - a%val(i) = a%val(i) * d(j) - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - - end subroutine z_coo_scal - - subroutine z_coo_scals(d,a,info) - use psb_error_mod - use psb_const_mod + + end subroutine z_coo_transp_1mat + + subroutine z_coo_transc_1mat(a) + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return + + call a%transp() + a%val(:) = conjg(a%val) -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return + end subroutine z_coo_transc_1mat - end subroutine z_coo_scals end module psb_z_base_mat_mod diff --git a/base/modules/psb_z_csc_mat_mod.f03 b/base/modules/psb_z_csc_mat_mod.f03 index 1d01c65b..c9e5bf06 100644 --- a/base/modules/psb_z_csc_mat_mod.f03 +++ b/base/modules/psb_z_csc_mat_mod.f03 @@ -8,161 +8,195 @@ module psb_z_csc_mat_mod complex(psb_dpk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => z_csc_get_nzeros - procedure, pass(a) :: get_fmt => z_csc_get_fmt - procedure, pass(a) :: get_diag => z_csc_get_diag - procedure, pass(a) :: z_base_csmm => z_csc_csmm - procedure, pass(a) :: z_base_csmv => z_csc_csmv - procedure, pass(a) :: z_base_cssm => z_csc_cssm - procedure, pass(a) :: z_base_cssv => z_csc_cssv - procedure, pass(a) :: z_scals => z_csc_scals - procedure, pass(a) :: z_scal => z_csc_scal - procedure, pass(a) :: csnmi => z_csc_csnmi - procedure, pass(a) :: reallocate_nz => z_csc_reallocate_nz - procedure, pass(a) :: csput => z_csc_csput - procedure, pass(a) :: allocate_mnnz => z_csc_allocate_mnnz - procedure, pass(a) :: cp_to_coo => c_cp_csc_to_coo - procedure, pass(a) :: cp_from_coo => c_cp_csc_from_coo - procedure, pass(a) :: cp_to_fmt => c_cp_csc_to_fmt - procedure, pass(a) :: cp_from_fmt => c_cp_csc_from_fmt - procedure, pass(a) :: mv_to_coo => c_mv_csc_to_coo - procedure, pass(a) :: mv_from_coo => c_mv_csc_from_coo - procedure, pass(a) :: mv_to_fmt => c_mv_csc_to_fmt - procedure, pass(a) :: mv_from_fmt => c_mv_csc_from_fmt - procedure, pass(a) :: csgetptn => z_csc_csgetptn - procedure, pass(a) :: z_csgetrow => z_csc_csgetrow - procedure, pass(a) :: get_size => z_csc_get_size - procedure, pass(a) :: free => z_csc_free - procedure, pass(a) :: trim => z_csc_trim - procedure, pass(a) :: print => z_csc_print - procedure, pass(a) :: sizeof => z_csc_sizeof - procedure, pass(a) :: reinit => z_csc_reinit - procedure, pass(a) :: z_csc_cp_from - generic, public :: cp_from => z_csc_cp_from - procedure, pass(a) :: z_csc_mv_from - generic, public :: mv_from => z_csc_mv_from - end type psb_z_csc_sparse_mat + procedure, pass(a) :: get_size => z_csc_get_size + procedure, pass(a) :: get_nzeros => z_csc_get_nzeros + procedure, pass(a) :: get_fmt => z_csc_get_fmt + procedure, pass(a) :: sizeof => z_csc_sizeof + procedure, pass(a) :: z_csmm => psb_z_csc_csmm + procedure, pass(a) :: z_csmv => psb_z_csc_csmv + procedure, pass(a) :: z_inner_cssm => psb_z_csc_cssm + procedure, pass(a) :: z_inner_cssv => psb_z_csc_cssv + procedure, pass(a) :: z_scals => psb_z_csc_scals + procedure, pass(a) :: z_scal => psb_z_csc_scal + procedure, pass(a) :: csnmi => psb_z_csc_csnmi + procedure, pass(a) :: reallocate_nz => psb_z_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_z_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_z_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_z_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_z_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_z_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_z_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_z_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_z_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_z_mv_csc_from_fmt + procedure, pass(a) :: csput => psb_z_csc_csput + procedure, pass(a) :: get_diag => psb_z_csc_get_diag + procedure, pass(a) :: csgetptn => psb_z_csc_csgetptn + procedure, pass(a) :: z_csgetrow => psb_z_csc_csgetrow + procedure, pass(a) :: get_nz_col => z_csc_get_nz_col + procedure, pass(a) :: reinit => psb_z_csc_reinit + procedure, pass(a) :: trim => psb_z_csc_trim + procedure, pass(a) :: print => psb_z_csc_print + procedure, pass(a) :: free => z_csc_free + procedure, pass(a) :: psb_z_csc_cp_from + generic, public :: cp_from => psb_z_csc_cp_from + procedure, pass(a) :: psb_z_csc_mv_from + generic, public :: mv_from => psb_z_csc_mv_from - private :: z_csc_get_nzeros, z_csc_csmm, z_csc_csmv, z_csc_cssm, z_csc_cssv, & - & z_csc_csput, z_csc_reallocate_nz, z_csc_allocate_mnnz, & - & z_csc_free, z_csc_print, z_csc_get_fmt, z_csc_csnmi, get_diag, & - & z_cp_csc_to_coo, z_cp_csc_from_coo, & - & z_mv_csc_to_coo, z_mv_csc_from_coo, & - & z_cp_csc_to_fmt, z_cp_csc_from_fmt, & - & z_mv_csc_to_fmt, z_mv_csc_from_fmt, & - & z_csc_scals, z_csc_scal, z_csc_trim, z_csc_csgetrow, z_csc_get_size, & - & z_csc_sizeof, z_csc_csgetptn, z_csc_get_nz_row, z_csc_reinit + end type psb_z_csc_sparse_mat + private :: z_csc_get_nzeros, z_csc_free, z_csc_get_fmt, & + & z_csc_get_size, z_csc_sizeof, z_csc_get_nz_col - interface - subroutine z_cp_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod + interface + subroutine psb_z_csc_reallocate_nz(nz,a) import psb_z_csc_sparse_mat - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine z_cp_csc_to_fmt_impl + integer, intent(in) :: nz + class(psb_z_csc_sparse_mat), intent(inout) :: a + end subroutine psb_z_csc_reallocate_nz end interface - + interface - subroutine z_cp_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod + subroutine psb_z_csc_reinit(a,clear) + import psb_z_csc_sparse_mat + class(psb_z_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_z_csc_reinit + end interface + + interface + subroutine psb_z_csc_trim(a) import psb_z_csc_sparse_mat class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine z_cp_csc_from_fmt_impl + end subroutine psb_z_csc_trim end interface - - - interface - subroutine z_cp_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod + + interface + subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) import psb_z_csc_sparse_mat + integer, intent(in) :: m,n + class(psb_z_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_z_csc_allocate_mnnz + end interface + + interface + subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_z_csc_sparse_mat + integer, intent(in) :: iout + class(psb_z_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_z_csc_print + end interface + + interface + subroutine psb_z_cp_csc_to_coo(a,b,info) + import psb_z_coo_sparse_mat, psb_z_csc_sparse_mat class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_cp_csc_to_coo_impl + end subroutine psb_z_cp_csc_to_coo end interface - + interface - subroutine z_cp_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csc_sparse_mat + subroutine psb_z_cp_csc_from_coo(a,b,info) + import psb_z_csc_sparse_mat, psb_z_coo_sparse_mat class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine z_cp_csc_from_coo_impl + end subroutine psb_z_cp_csc_from_coo end interface - + interface - subroutine z_mv_csc_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csc_sparse_mat + subroutine psb_z_cp_csc_to_fmt(a,b,info) + import psb_z_csc_sparse_mat, psb_z_base_sparse_mat + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_cp_csc_to_fmt + end interface + + interface + subroutine psb_z_cp_csc_from_fmt(a,b,info) + import psb_z_csc_sparse_mat, psb_z_base_sparse_mat + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_z_cp_csc_from_fmt + end interface + + interface + subroutine psb_z_mv_csc_to_coo(a,b,info) + import psb_z_csc_sparse_mat, psb_z_coo_sparse_mat class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_csc_to_fmt_impl + end subroutine psb_z_mv_csc_to_coo end interface - + interface - subroutine z_mv_csc_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csc_sparse_mat + subroutine psb_z_mv_csc_from_coo(a,b,info) + import psb_z_csc_sparse_mat, psb_z_coo_sparse_mat + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_mv_csc_from_coo + end interface + + interface + subroutine psb_z_mv_csc_to_fmt(a,b,info) + import psb_z_csc_sparse_mat, psb_z_base_sparse_mat + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_mv_csc_to_fmt + end interface + + interface + subroutine psb_z_mv_csc_from_fmt(a,b,info) + import psb_z_csc_sparse_mat, psb_z_base_sparse_mat class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_csc_from_fmt_impl + end subroutine psb_z_mv_csc_from_fmt end interface - - + interface - subroutine z_mv_csc_to_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csc_sparse_mat + subroutine psb_z_csc_cp_from(a,b) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine z_mv_csc_to_coo_impl + type(psb_z_csc_sparse_mat), intent(in) :: b + end subroutine psb_z_csc_cp_from end interface - + interface - subroutine z_mv_csc_from_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csc_sparse_mat - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine z_mv_csc_from_coo_impl + subroutine psb_z_csc_mv_from(a,b) + import psb_z_csc_sparse_mat, psb_dpk_ + class(psb_z_csc_sparse_mat), intent(inout) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: b + end subroutine psb_z_csc_mv_from end interface - + + interface - subroutine z_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_z_csc_sparse_mat + subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine z_csc_csput_impl + end subroutine psb_z_csc_csput end interface - + interface - subroutine z_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_z_csc_sparse_mat - implicit none - + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -172,16 +206,13 @@ module psb_z_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine z_csc_csgetptn_impl + end subroutine psb_z_csc_csgetptn end interface - + interface - subroutine z_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_z_csc_sparse_mat - implicit none - + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -192,61 +223,98 @@ module psb_z_csc_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine z_csc_csgetrow_impl + end subroutine psb_z_csc_csgetrow end interface - interface z_csc_cssm_impl - subroutine z_csc_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csc_sparse_mat + interface + subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_z_csc_sparse_mat, psb_dpk_, psb_z_coo_sparse_mat + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csc_csgetblk + end interface + + interface + subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csc_cssv_impl - subroutine z_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csc_sparse_mat + end subroutine psb_z_csc_cssv + subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csc_cssm_impl + end subroutine psb_z_csc_cssm end interface - - interface z_csc_csmm_impl - subroutine z_csc_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csc_sparse_mat + + interface + subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csc_csmv_impl - subroutine z_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csc_sparse_mat + end subroutine psb_z_csc_csmv + subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csc_csmm_impl + end subroutine psb_z_csc_csmm end interface - - interface z_csc_csnmi_impl - function z_csc_csnmi_impl(a) result(res) - use psb_const_mod - import psb_z_csc_sparse_mat + + + interface + function psb_z_csc_csnmi(a) result(res) + import psb_z_csc_sparse_mat, psb_dpk_ class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function z_csc_csnmi_impl + end function psb_z_csc_csnmi + end interface + + interface + subroutine psb_z_csc_get_diag(a,d,info) + import psb_z_csc_sparse_mat, psb_dpk_ + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_csc_get_diag + end interface + + interface + subroutine psb_z_csc_scal(d,a,info) + import psb_z_csc_sparse_mat, psb_dpk_ + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_csc_scal + end interface + + interface + subroutine psb_z_csc_scals(d,a,info) + import psb_z_csc_sparse_mat, psb_dpk_ + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_z_csc_scals end interface - contains @@ -268,7 +336,7 @@ contains class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 - res = res + 2*psb_sizeof_dp * size(a%val) + res = res + 2 * psb_sizeof_dp * size(a%val) res = res + psb_sizeof_int * size(a%icp) res = res + psb_sizeof_int * size(a%ia) @@ -345,339 +413,6 @@ contains !===================================== - subroutine z_csc_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_z_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='z_csc_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_reallocate_nz - - subroutine z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='z_csc_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call z_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_csc_csput - - subroutine z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call z_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_csgetptn - - - subroutine z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call z_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_csgetrow - - - subroutine z_csc_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_csgetblk - - - subroutine z_csc_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_csclip - - subroutine z_csc_free(a) implicit none @@ -694,886 +429,4 @@ contains end subroutine z_csc_free - subroutine z_csc_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = szero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_reinit - - subroutine z_csc_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, n - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - n = a%get_ncols() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_trim - - subroutine c_cp_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_to_coo - - subroutine c_cp_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_from_coo - - - subroutine c_cp_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_to_fmt - - subroutine c_cp_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_cp_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_cp_csc_from_fmt - - - subroutine c_mv_csc_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_to_coo - - subroutine c_mv_csc_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_from_coo - - - subroutine c_mv_csc_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_to_fmt - - subroutine c_mv_csc_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call c_mv_csc_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine c_mv_csc_from_fmt - - subroutine z_csc_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_z_csc_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%icp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_allocate_mnnz - - - subroutine z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_z_csc_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='z_csc_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%icp(i),a%icp(i+1)-1 - write(iout,frmtv) (a%ia(j)),(i),a%val(j) - end do - enddo - endif - endif - - end subroutine z_csc_print - - - subroutine z_csc_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(out) :: a - type(psb_z_csc_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) - a%icp = b%icp - a%ia = b%ia - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_csc_cp_from - - subroutine z_csc_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_csc_sparse_mat), intent(out) :: a - type(psb_z_csc_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_csc_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine z_csc_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_csc_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call z_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_csmv - - subroutine z_csc_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - logical :: tra - Integer :: err_act - character(len=20) :: name='z_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call z_csc_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_csmm - - - subroutine z_csc_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_csc_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call z_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine z_csc_cssv - - - - subroutine z_csc_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - Integer :: err_act - character(len=20) :: name='z_csc_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call z_csc_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_cssm - - function z_csc_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = z_csc_csnmi_impl(a) - - return - - end function z_csc_csnmi - - subroutine z_csc_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%icp(i),a%icp(i+1)-1 - j=a%ia(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = szero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_get_diag - - - subroutine z_csc_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, n - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - n = a%get_ncols() - if (size(d) < n) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, n - do j = a%icp(i), a%icp(i+1) -1 - a%val(j) = a%val(j) * d(a%ia(j)) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_scal - - - subroutine z_csc_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csc_scals - - - end module psb_z_csc_mat_mod diff --git a/base/modules/psb_z_csr_mat_mod.f03 b/base/modules/psb_z_csr_mat_mod.f03 index 395217c5..26a89f1b 100644 --- a/base/modules/psb_z_csr_mat_mod.f03 +++ b/base/modules/psb_z_csr_mat_mod.f03 @@ -8,165 +8,195 @@ module psb_z_csr_mat_mod complex(psb_dpk_), allocatable :: val(:) contains - procedure, pass(a) :: get_nzeros => z_csr_get_nzeros - procedure, pass(a) :: get_fmt => z_csr_get_fmt - procedure, pass(a) :: get_diag => z_csr_get_diag - procedure, pass(a) :: z_base_csmm => z_csr_csmm - procedure, pass(a) :: z_base_csmv => z_csr_csmv - procedure, pass(a) :: z_base_cssm => z_csr_cssm - procedure, pass(a) :: z_base_cssv => z_csr_cssv - procedure, pass(a) :: z_scals => z_csr_scals - procedure, pass(a) :: z_scal => z_csr_scal - procedure, pass(a) :: csnmi => z_csr_csnmi - procedure, pass(a) :: reallocate_nz => z_csr_reallocate_nz - procedure, pass(a) :: csput => z_csr_csput - procedure, pass(a) :: allocate_mnnz => z_csr_allocate_mnnz - procedure, pass(a) :: cp_to_coo => z_cp_csr_to_coo - procedure, pass(a) :: cp_from_coo => z_cp_csr_from_coo - procedure, pass(a) :: cp_to_fmt => z_cp_csr_to_fmt - procedure, pass(a) :: cp_from_fmt => z_cp_csr_from_fmt - procedure, pass(a) :: mv_to_coo => z_mv_csr_to_coo - procedure, pass(a) :: mv_from_coo => z_mv_csr_from_coo - procedure, pass(a) :: mv_to_fmt => z_mv_csr_to_fmt - procedure, pass(a) :: mv_from_fmt => z_mv_csr_from_fmt - procedure, pass(a) :: csgetptn => z_csr_csgetptn - procedure, pass(a) :: z_csgetrow => z_csr_csgetrow - procedure, pass(a) :: get_nz_row => z_csr_get_nz_row - procedure, pass(a) :: get_size => z_csr_get_size - procedure, pass(a) :: free => z_csr_free - procedure, pass(a) :: trim => z_csr_trim - procedure, pass(a) :: print => z_csr_print - procedure, pass(a) :: sizeof => z_csr_sizeof - procedure, pass(a) :: reinit => z_csr_reinit - procedure, pass(a) :: z_csr_cp_from - generic, public :: cp_from => z_csr_cp_from - procedure, pass(a) :: z_csr_mv_from - generic, public :: mv_from => z_csr_mv_from + procedure, pass(a) :: get_size => z_csr_get_size + procedure, pass(a) :: get_nzeros => z_csr_get_nzeros + procedure, pass(a) :: get_fmt => z_csr_get_fmt + procedure, pass(a) :: sizeof => z_csr_sizeof + procedure, pass(a) :: z_csmm => psb_z_csr_csmm + procedure, pass(a) :: z_csmv => psb_z_csr_csmv + procedure, pass(a) :: z_inner_cssm => psb_z_csr_cssm + procedure, pass(a) :: z_inner_cssv => psb_z_csr_cssv + procedure, pass(a) :: z_scals => psb_z_csr_scals + procedure, pass(a) :: z_scal => psb_z_csr_scal + procedure, pass(a) :: csnmi => psb_z_csr_csnmi + procedure, pass(a) :: reallocate_nz => psb_z_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_z_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_z_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_z_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_z_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_z_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_z_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_z_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_z_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_z_mv_csr_from_fmt + procedure, pass(a) :: csput => psb_z_csr_csput + procedure, pass(a) :: get_diag => psb_z_csr_get_diag + procedure, pass(a) :: csgetptn => psb_z_csr_csgetptn + procedure, pass(a) :: z_csgetrow => psb_z_csr_csgetrow + procedure, pass(a) :: get_nz_row => z_csr_get_nz_row + procedure, pass(a) :: reinit => psb_z_csr_reinit + procedure, pass(a) :: trim => psb_z_csr_trim + procedure, pass(a) :: print => psb_z_csr_print + procedure, pass(a) :: free => z_csr_free + procedure, pass(a) :: psb_z_csr_cp_from + generic, public :: cp_from => psb_z_csr_cp_from + procedure, pass(a) :: psb_z_csr_mv_from + generic, public :: mv_from => psb_z_csr_mv_from end type psb_z_csr_sparse_mat - private :: z_csr_get_nzeros, z_csr_csmm, z_csr_csmv, z_csr_cssm, z_csr_cssv, & - & z_csr_csput, z_csr_reallocate_nz, z_csr_allocate_mnnz, & - & z_csr_free, z_csr_print, z_csr_get_fmt, z_csr_csnmi, get_diag, & - & z_cp_csr_to_coo, z_cp_csr_from_coo, & - & z_mv_csr_to_coo, z_mv_csr_from_coo, & - & z_cp_csr_to_fmt, z_cp_csr_from_fmt, & - & z_mv_csr_to_fmt, z_mv_csr_from_fmt, & - & z_csr_scals, z_csr_scal, z_csr_trim, z_csr_csgetrow, z_csr_get_size, & - & z_csr_sizeof, z_csr_csgetptn, z_csr_get_nz_row, z_csr_reinit -!!$, & -!!$ & z_csr_mv_from, z_csr_mv_from + private :: z_csr_get_nzeros, z_csr_free, z_csr_get_fmt, & + & z_csr_get_size, z_csr_sizeof, z_csr_get_nz_row - - interface - subroutine z_cp_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod + interface + subroutine psb_z_csr_reallocate_nz(nz,a) import psb_z_csr_sparse_mat - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine z_cp_csr_to_fmt_impl + integer, intent(in) :: nz + class(psb_z_csr_sparse_mat), intent(inout) :: a + end subroutine psb_z_csr_reallocate_nz end interface - + interface - subroutine z_cp_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod + subroutine psb_z_csr_reinit(a,clear) + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_z_csr_reinit + end interface + + interface + subroutine psb_z_csr_trim(a) import psb_z_csr_sparse_mat class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - end subroutine z_cp_csr_from_fmt_impl + end subroutine psb_z_csr_trim end interface - - - interface - subroutine z_cp_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod + + interface + subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) + import psb_z_csr_sparse_mat + integer, intent(in) :: m,n + class(psb_z_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine psb_z_csr_allocate_mnnz + end interface + + interface + subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) import psb_z_csr_sparse_mat + integer, intent(in) :: iout + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_z_csr_print + end interface + + interface + subroutine psb_z_cp_csr_to_coo(a,b,info) + import psb_z_coo_sparse_mat, psb_z_csr_sparse_mat class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_cp_csr_to_coo_impl + end subroutine psb_z_cp_csr_to_coo end interface - + interface - subroutine z_cp_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csr_sparse_mat + subroutine psb_z_cp_csr_from_coo(a,b,info) + import psb_z_csr_sparse_mat, psb_z_coo_sparse_mat class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer, intent(out) :: info - end subroutine z_cp_csr_from_coo_impl + end subroutine psb_z_cp_csr_from_coo end interface - + interface - subroutine z_mv_csr_to_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csr_sparse_mat + subroutine psb_z_cp_csr_to_fmt(a,b,info) + import psb_z_csr_sparse_mat, psb_z_base_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_cp_csr_to_fmt + end interface + + interface + subroutine psb_z_cp_csr_from_fmt(a,b,info) + import psb_z_csr_sparse_mat, psb_z_base_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine psb_z_cp_csr_from_fmt + end interface + + interface + subroutine psb_z_mv_csr_to_coo(a,b,info) + import psb_z_csr_sparse_mat, psb_z_coo_sparse_mat class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_csr_to_fmt_impl + end subroutine psb_z_mv_csr_to_coo end interface - + interface - subroutine z_mv_csr_from_fmt_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csr_sparse_mat + subroutine psb_z_mv_csr_from_coo(a,b,info) + import psb_z_csr_sparse_mat, psb_z_coo_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_mv_csr_from_coo + end interface + + interface + subroutine psb_z_mv_csr_to_fmt(a,b,info) + import psb_z_csr_sparse_mat, psb_z_base_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine psb_z_mv_csr_to_fmt + end interface + + interface + subroutine psb_z_mv_csr_from_fmt(a,b,info) + import psb_z_csr_sparse_mat, psb_z_base_sparse_mat class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info - end subroutine z_mv_csr_from_fmt_impl + end subroutine psb_z_mv_csr_from_fmt end interface - - + interface - subroutine z_mv_csr_to_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csr_sparse_mat + subroutine psb_z_csr_cp_from(a,b) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - end subroutine z_mv_csr_to_coo_impl + type(psb_z_csr_sparse_mat), intent(in) :: b + end subroutine psb_z_csr_cp_from end interface - + interface - subroutine z_mv_csr_from_coo_impl(a,b,info) - use psb_const_mod - use psb_z_base_mat_mod - import psb_z_csr_sparse_mat - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - end subroutine z_mv_csr_from_coo_impl + subroutine psb_z_csr_mv_from(a,b) + import psb_z_csr_sparse_mat, psb_dpk_ + class(psb_z_csr_sparse_mat), intent(inout) :: a + type(psb_z_csr_sparse_mat), intent(inout) :: b + end subroutine psb_z_csr_mv_from end interface - + + interface - subroutine z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - import psb_z_csr_sparse_mat + subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine z_csr_csput_impl + end subroutine psb_z_csr_csput end interface - + interface - subroutine z_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_z_csr_sparse_mat - implicit none - + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -176,16 +206,13 @@ module psb_z_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine z_csr_csgetptn_impl + end subroutine psb_z_csr_csgetptn end interface - + interface - subroutine z_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - use psb_const_mod - import psb_z_csr_sparse_mat - implicit none - + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a integer, intent(in) :: imin,imax integer, intent(out) :: nz @@ -196,58 +223,96 @@ module psb_z_csr_mat_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - end subroutine z_csr_csgetrow_impl + end subroutine psb_z_csr_csgetrow end interface - interface z_csr_cssm_impl - subroutine z_csr_cssv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csr_sparse_mat + interface + subroutine psb_z_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_z_csr_sparse_mat, psb_dpk_, psb_z_coo_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csr_csgetblk + end interface + + interface + subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csr_cssv_impl - subroutine z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csr_sparse_mat + end subroutine psb_z_csr_cssv + subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csr_cssm_impl + end subroutine psb_z_csr_cssm end interface - - interface z_csr_csmm_impl - subroutine z_csr_csmv_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csr_sparse_mat + + interface + subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csr_csmv_impl - subroutine z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - use psb_const_mod - import psb_z_csr_sparse_mat + end subroutine psb_z_csr_csmv + subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) integer, intent(out) :: info character, optional, intent(in) :: trans - end subroutine z_csr_csmm_impl + end subroutine psb_z_csr_csmm end interface - - interface z_csr_csnmi_impl - function z_csr_csnmi_impl(a) result(res) - use psb_const_mod - import psb_z_csr_sparse_mat + + + interface + function psb_z_csr_csnmi(a) result(res) + import psb_z_csr_sparse_mat, psb_dpk_ class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - end function z_csr_csnmi_impl + end function psb_z_csr_csnmi + end interface + + interface + subroutine psb_z_csr_get_diag(a,d,info) + import psb_z_csr_sparse_mat, psb_dpk_ + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_csr_get_diag + end interface + + interface + subroutine psb_z_csr_scal(d,a,info) + import psb_z_csr_sparse_mat, psb_dpk_ + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_csr_scal + end interface + + interface + subroutine psb_z_csr_scals(d,a,info) + import psb_z_csr_sparse_mat, psb_dpk_ + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_z_csr_scals end interface @@ -272,7 +337,7 @@ contains class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res res = 8 - res = res + 2*psb_sizeof_dp * size(a%val) + res = res + 2 * psb_sizeof_dp * size(a%val) res = res + psb_sizeof_int * size(a%irp) res = res + psb_sizeof_int * size(a%ja) @@ -319,7 +384,7 @@ contains function z_csr_get_nz_row(idx,a) result(res) - use psb_const_mod + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a @@ -348,341 +413,6 @@ contains ! !===================================== - - subroutine z_csr_reallocate_nz(nz,a) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: nz - class(psb_z_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='z_csr_reallocate_nz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& - & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_reallocate_nz - - subroutine z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_const_mod - use psb_error_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - - Integer :: err_act - character(len=20) :: name='z_csr_csput' - logical, parameter :: debug=.false. - integer :: nza, i,j,k, nzl, isza, int_err(5) - - call psb_erractionsave(err_act) - info = 0 - - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (nz == 0) return - - call z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_csr_csput - - subroutine z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call z_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_csgetptn - - - subroutine z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - call z_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_csgetrow - - - subroutine z_csr_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - Integer :: err_act, nzin, nzout - character(len=20) :: name='csget' - logical :: append_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - if (present(append)) then - append_ = append - else - append_ = .false. - endif - if (append_) then - nzin = a%get_nzeros() - else - nzin = 0 - endif - - call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin, jmax=jmax, iren=iren, append=append_, & - & nzin=nzin, rscale=rscale, cscale=cscale) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_csgetblk - - - subroutine z_csr_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - character(len=20) :: name='csget' - logical :: rscale_, cscale_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - nzin = 0 - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - end if - if (present(imax)) then - imax_ = imax - else - imax_ = a%get_nrows() - end if - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - end if - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%get_ncols() - end if - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - end if - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - end if - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? - endif - if (cscale_) then - nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? - endif - call b%allocate(mb,nb) - - call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& - & jmin=jmin_, jmax=jmax_, append=.false., & - & nzin=nzin, rscale=rscale_, cscale=cscale_) - - if (info /= 0) goto 9999 - - call b%set_nzeros(nzin+nzout) - call b%fix(info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_csclip - - subroutine z_csr_free(a) implicit none @@ -699,906 +429,5 @@ contains end subroutine z_csr_free - subroutine z_csr_reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - - Integer :: err_act, info - character(len=20) :: name='reinit' - logical :: clear_ - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - - if (present(clear)) then - clear_ = clear - else - clear_ = .true. - end if - - if (a%is_bld() .or. a%is_upd()) then - ! do nothing - return - else if (a%is_asb()) then - if (clear_) a%val(:) = zzero - call a%set_upd() - else - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_reinit - - - subroutine z_csr_trim(a) - use psb_realloc_mod - use psb_error_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - Integer :: err_act, info, nz, m - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - m = a%get_nrows() - nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_trim - - - subroutine z_cp_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_csr_to_coo - - subroutine z_cp_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_csr_from_coo - - - subroutine z_cp_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_csr_to_fmt - - subroutine z_cp_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_cp_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_cp_csr_from_fmt - - - subroutine z_mv_csr_to_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_csr_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_csr_to_coo - - subroutine z_mv_csr_from_coo(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_csr_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_csr_from_coo - - - subroutine z_mv_csr_to_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_csr_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_csr_to_fmt - - subroutine z_mv_csr_from_fmt(a,b,info) - use psb_error_mod - use psb_realloc_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_fmt' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call z_mv_csr_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_mv_csr_from_fmt - - - subroutine z_csr_allocate_mnnz(m,n,a,nz) - use psb_error_mod - use psb_realloc_mod - implicit none - integer, intent(in) :: m,n - class(psb_z_csr_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - Integer :: err_act, info, nz_ - character(len=20) :: name='allocate_mnz' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) - goto 9999 - endif - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) - goto 9999 - endif - if (present(nz)) then - nz_ = nz - else - nz_ = max(7*m,7*n,1) - end if - if (nz_ < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) - goto 9999 - endif - - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then - a%irp=0 - call a%set_nrows(m) - call a%set_ncols(n) - call a%set_bld() - call a%set_triangle(.false.) - call a%set_unit(.false.) - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_allocate_mnnz - - - subroutine z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_string_mod - implicit none - - integer, intent(in) :: iout - class(psb_z_csr_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act - character(len=20) :: name='z_csr_print' - logical, parameter :: debug=.false. - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni, nr, nc, nz - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% COO' - endif - - nr = a%get_nrows() - nc = a%get_ncols() - nz = a%get_nzeros() - nmx = max(nr,nc,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - write(iout,*) nr, nc, nz - if(present(iv)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) - end do - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) - end do - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) - end do - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 - write(iout,frmtv) (i),(a%ja(j)),a%val(j) - end do - enddo - endif - endif - - end subroutine z_csr_print - - - subroutine z_csr_cp_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(out) :: a - type(psb_z_csr_sparse_mat), intent(in) :: b - - - Integer :: err_act, info - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = 0 - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) - a%irp = b%irp - a%ja = b%ja - a%val = b%val - - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_csr_cp_from - - subroutine z_csr_mv_from(a,b) - use psb_error_mod - implicit none - - class(psb_z_csr_sparse_mat), intent(out) :: a - type(psb_z_csr_sparse_mat), intent(inout) :: b - - - Integer :: err_act, info - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - - end subroutine z_csr_mv_from - - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine z_csr_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - complex(psb_dpk_) :: acc - logical :: tra - Integer :: err_act - character(len=20) :: name='z_csr_csmv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_csmv - - subroutine z_csr_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_), allocatable :: acc(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='z_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - - - call z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_csmm - - - subroutine z_csr_cssv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: tmp(:) - logical :: tra - Integer :: err_act - character(len=20) :: name='z_csr_cssv' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - - end subroutine z_csr_cssv - - - - subroutine z_csr_cssm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - - character :: trans_ - integer :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: tmp(:,:) - logical :: tra - Integer :: err_act - character(len=20) :: name='z_csr_csmm' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - if (.not.a%is_asb()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - if (.not. (a%is_triangle())) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - call z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) - call psb_erractionrestore(err_act) - return - - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_cssm - - function z_csr_csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - - res = z_csr_csnmi_impl(a) - - return - - end function z_csr_csnmi - - subroutine z_csr_get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act, mnm, i, j, k - character(len=20) :: name='get_diag' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - - do i=1, mnm - do k=a%irp(i),a%irp(i+1)-1 - j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then - d(i) = a%val(k) - endif - enddo - end do - do i=mnm+1,size(d) - d(i) = zzero - end do - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_get_diag - - - subroutine z_csr_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - m = a%get_nrows() - if (size(d) < m) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 - a%val(j) = a%val(j) * d(i) - end do - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_scal - - - subroutine z_csr_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act,mnm, i, j, m - character(len=20) :: name='scal' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - - do i=1,a%get_nzeros() - a%val(i) = a%val(i) * d - enddo - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csr_scals - - end module psb_z_csr_mat_mod diff --git a/base/modules/psb_z_mat_mod.f03 b/base/modules/psb_z_mat_mod.f03 index 81357d4d..a24c37b8 100644 --- a/base/modules/psb_z_mat_mod.f03 +++ b/base/modules/psb_z_mat_mod.f03 @@ -9,20 +9,6 @@ module psb_z_mat_mod class(psb_z_base_sparse_mat), allocatable :: a contains - ! Setters - procedure, pass(a) :: set_nrows - procedure, pass(a) :: set_ncols - procedure, pass(a) :: set_dupl - procedure, pass(a) :: set_state - procedure, pass(a) :: set_null - procedure, pass(a) :: set_bld - procedure, pass(a) :: set_upd - procedure, pass(a) :: set_asb - procedure, pass(a) :: set_sorted - procedure, pass(a) :: set_upper - procedure, pass(a) :: set_lower - procedure, pass(a) :: set_triangle - procedure, pass(a) :: set_unit ! Getters procedure, pass(a) :: get_nrows procedure, pass(a) :: get_ncols @@ -40,90 +26,574 @@ module psb_z_mat_mod procedure, pass(a) :: is_lower procedure, pass(a) :: is_triangle procedure, pass(a) :: is_unit - procedure, pass(a) :: get_fmt => sparse_get_fmt - procedure, pass(a) :: sizeof => z_sizeof + procedure, pass(a) :: get_fmt => psb_z_get_fmt + procedure, pass(a) :: sizeof => psb_z_sizeof + ! Setters + procedure, pass(a) :: set_nrows => psb_z_set_nrows + procedure, pass(a) :: set_ncols => psb_z_set_ncols + procedure, pass(a) :: set_dupl => psb_z_set_dupl + procedure, pass(a) :: set_state => psb_z_set_state + procedure, pass(a) :: set_null => psb_z_set_null + procedure, pass(a) :: set_bld => psb_z_set_bld + procedure, pass(a) :: set_upd => psb_z_set_upd + procedure, pass(a) :: set_asb => psb_z_set_asb + procedure, pass(a) :: set_sorted => psb_z_set_sorted + procedure, pass(a) :: set_upper => psb_z_set_upper + procedure, pass(a) :: set_lower => psb_z_set_lower + procedure, pass(a) :: set_triangle => psb_z_set_triangle + procedure, pass(a) :: set_unit => psb_z_set_unit ! Memory/data management - procedure, pass(a) :: csall - procedure, pass(a) :: free - procedure, pass(a) :: trim - procedure, pass(a) :: csput - procedure, pass(a) :: z_csgetptn - procedure, pass(a) :: z_csgetrow - procedure, pass(a) :: z_csgetblk + procedure, pass(a) :: csall => psb_z_csall + procedure, pass(a) :: free => psb_z_free + procedure, pass(a) :: trim => psb_z_trim + procedure, pass(a) :: csput => psb_z_csput + procedure, pass(a) :: z_csgetptn => psb_z_csgetptn + procedure, pass(a) :: z_csgetrow => psb_z_csgetrow + procedure, pass(a) :: z_csgetblk => psb_z_csgetblk generic, public :: csget => z_csgetptn, z_csgetrow, z_csgetblk - procedure, pass(a) :: csclip - procedure, pass(a) :: reall => reallocate_nz - procedure, pass(a) :: get_neigh - procedure, pass(a) :: z_cscnv - procedure, pass(a) :: z_cscnv_ip - generic, public :: cscnv => z_cscnv, z_cscnv_ip - procedure, pass(a) :: reinit - procedure, pass(a) :: print => sparse_print - procedure, pass(a) :: z_mv_from + procedure, pass(a) :: z_csclip => psb_z_csclip + procedure, pass(a) :: z_b_csclip => psb_z_b_csclip + generic, public :: csclip => z_b_csclip, z_csclip + procedure, pass(a) :: z_clip_d_ip => psb_z_clip_d_ip + procedure, pass(a) :: z_clip_d => psb_z_clip_d + generic, public :: clip_diag => z_clip_d_ip, z_clip_d + procedure, pass(a) :: reall => psb_z_reallocate_nz + procedure, pass(a) :: get_neigh => psb_z_get_neigh + procedure, pass(a) :: z_cscnv => psb_z_cscnv + procedure, pass(a) :: z_cscnv_ip => psb_z_cscnv_ip + procedure, pass(a) :: z_cscnv_base => psb_z_cscnv_base + generic, public :: cscnv => z_cscnv, z_cscnv_ip, z_cscnv_base + procedure, pass(a) :: reinit => psb_z_reinit + procedure, pass(a) :: print => psb_z_sparse_print + procedure, pass(a) :: z_mv_from => psb_z_mv_from generic, public :: mv_from => z_mv_from - procedure, pass(a) :: z_cp_from + procedure, pass(a) :: z_mv_to => psb_z_mv_to + generic, public :: mv_to => z_mv_to + procedure, pass(a) :: z_cp_from => psb_z_cp_from generic, public :: cp_from => z_cp_from + procedure, pass(a) :: z_cp_to => psb_z_cp_to + generic, public :: cp_to => z_cp_to + procedure, pass(a) :: z_transp_1mat => psb_z_transp_1mat + procedure, pass(a) :: z_transp_2mat => psb_z_transp_2mat + generic, public :: transp => z_transp_1mat, z_transp_2mat + procedure, pass(a) :: z_transc_1mat => psb_z_transc_1mat + procedure, pass(a) :: z_transc_2mat => psb_z_transc_2mat + generic, public :: transc => z_transc_1mat, z_transc_2mat + ! Computational routines - procedure, pass(a) :: get_diag - procedure, pass(a) :: csnmi - procedure, pass(a) :: z_csmv - procedure, pass(a) :: z_csmm + procedure, pass(a) :: get_diag => psb_z_get_diag + procedure, pass(a) :: csnmi => psb_z_csnmi + procedure, pass(a) :: z_csmv => psb_z_csmv + procedure, pass(a) :: z_csmm => psb_z_csmm generic, public :: csmm => z_csmm, z_csmv - procedure, pass(a) :: z_scals - procedure, pass(a) :: z_scal - generic, public :: scal => z_scals, z_scal - procedure, pass(a) :: z_cssv - procedure, pass(a) :: z_cssm + procedure, pass(a) :: z_scals => psb_z_scals + procedure, pass(a) :: z_scal => psb_z_scal + generic, public :: scal => z_scals, z_scal + procedure, pass(a) :: z_cssv => psb_z_cssv + procedure, pass(a) :: z_cssm => psb_z_cssm generic, public :: cssm => z_cssm, z_cssv end type psb_z_sparse_mat private :: get_nrows, get_ncols, get_nzeros, get_size, & & get_state, get_dupl, is_null, is_bld, is_upd, & - & is_asb, is_sorted, is_upper, is_lower, is_triangle, & - & is_unit, get_neigh, csall, csput, z_csgetrow,& - & z_csgetblk, csclip, z_cscnv, z_cscnv_ip, & - & reallocate_nz, free, trim, & - & sparse_print, reinit, & - & set_nrows, set_ncols, set_dupl, & - & set_state, set_null, set_bld, & - & set_upd, set_asb, set_sorted, & - & set_upper, set_lower, set_triangle, & - & set_unit, get_diag, get_nz_row, z_csgetptn, & - & z_mv_from, z_cp_from + & is_asb, is_sorted, is_upper, is_lower, is_triangle interface psb_sizeof - module procedure z_sizeof + module procedure psb_z_sizeof + end interface + + + !===================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !===================================== + + + interface + subroutine psb_z_set_nrows(m,a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + end subroutine psb_z_set_nrows + end interface + + interface + subroutine psb_z_set_ncols(n,a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_z_set_ncols + end interface + + interface + subroutine psb_z_set_state(n,a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_z_set_state + end interface + + interface + subroutine psb_z_set_dupl(n,a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + end subroutine psb_z_set_dupl + end interface + + interface + subroutine psb_z_set_null(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_set_null + end interface + + interface + subroutine psb_z_set_bld(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_set_bld + end interface + + interface + subroutine psb_z_set_upd(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_set_upd + end interface + + interface + subroutine psb_z_set_asb(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_set_asb + end interface + + interface + subroutine psb_z_set_sorted(a,val) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_sorted + end interface + + interface + subroutine psb_z_set_triangle(a,val) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_triangle + end interface + + interface + subroutine psb_z_set_unit(a,val) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_unit + end interface + + interface + subroutine psb_z_set_lower(a,val) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_lower + end interface + + interface + subroutine psb_z_set_upper(a,val) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_upper + end interface + + + interface + subroutine psb_z_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + import psb_z_sparse_mat + integer, intent(in) :: iout + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_z_sparse_print + end interface + + interface + subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_z_get_neigh + end interface + + interface + subroutine psb_z_csall(nr,nc,a,info,nz) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + end subroutine psb_z_csall + end interface + + interface + subroutine psb_z_reallocate_nz(nz,a) + import psb_z_sparse_mat + integer, intent(in) :: nz + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_reallocate_nz + end interface + + interface + subroutine psb_z_free(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_free + end interface + + interface + subroutine psb_z_trim(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_trim + end interface + + interface + subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine psb_z_csput + end interface + + interface + subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csgetptn + end interface + + interface + subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csgetrow end interface + + interface + subroutine psb_z_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csgetblk + end interface + + interface + subroutine psb_z_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csclip + end interface + + interface + subroutine psb_z_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import psb_z_sparse_mat, psb_dpk_, psb_z_coo_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_b_csclip + end interface + + interface + subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_z_cscnv + end interface + + interface + subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(out) :: iinfo + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_z_cscnv_ip + end interface + + + interface + subroutine psb_z_cscnv_base(a,b,info,dupl) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + end subroutine psb_z_cscnv_base + end interface + + interface + subroutine psb_z_clip_d(a,b,info) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer,intent(out) :: info + end subroutine psb_z_clip_d + end interface + + interface + subroutine psb_z_clip_d_ip(a,info) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + end subroutine psb_z_clip_d_ip + end interface + + interface + subroutine psb_z_mv_from(a,b) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_mv_from + end interface + + interface + subroutine psb_z_cp_from(a,b) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + end subroutine psb_z_cp_from + end interface + + interface + subroutine psb_z_mv_to(a,b) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + end subroutine psb_z_mv_to + end interface + + interface + subroutine psb_z_cp_to(a,b) + import psb_z_sparse_mat, psb_dpk_, psb_z_base_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + end subroutine psb_z_cp_to + end interface + interface psb_move_alloc - module procedure z_sparse_mat_move + subroutine psb_z_sparse_mat_move(a,b,info) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_z_sparse_mat_move end interface + interface psb_clone - module procedure z_sparse_mat_clone + subroutine psb_z_sparse_mat_clone(a,b,info) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_z_sparse_mat_clone + end interface + + interface + subroutine psb_z_transp_1mat(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_transp_1mat end interface + + interface + subroutine psb_z_transp_2mat(a,b) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_sparse_mat), intent(in) :: b + end subroutine psb_z_transp_2mat + end interface + + interface + subroutine psb_z_transc_1mat(a) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + end subroutine psb_z_transc_1mat + end interface + + interface + subroutine psb_z_transc_2mat(a,b) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_sparse_mat), intent(in) :: b + end subroutine psb_z_transc_2mat + end interface + + interface + subroutine psb_z_reinit(a,clear) + import psb_z_sparse_mat + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_z_reinit + + end interface + + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== interface psb_csmm - module procedure z_csmm, z_csmv + subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_csmm + subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_csmv end interface - + interface psb_cssm - module procedure z_cssm, z_cssv + subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_z_cssm + subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_z_cssv end interface - - interface psb_csnmi - module procedure csnmi + + interface + function psb_z_csnmi(a) result(res) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_z_csnmi + end interface + + interface + subroutine psb_z_get_diag(a,d,info) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_get_diag end interface interface psb_scal - module procedure z_scals, z_scal + subroutine psb_z_scal(d,a,info) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_z_scal + subroutine psb_z_scals(d,a,info) + import psb_z_sparse_mat, psb_dpk_ + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_z_scals end interface + + + contains @@ -140,7 +610,7 @@ contains !===================================== - function z_sizeof(a) result(res) + function psb_z_sizeof(a) result(res) implicit none class(psb_z_sparse_mat), intent(in) :: a integer(psb_long_int_k_) :: res @@ -150,11 +620,11 @@ contains res = a%a%sizeof() end if - end function z_sizeof + end function psb_z_sizeof - function sparse_get_fmt(a) result(res) + function psb_z_get_fmt(a) result(res) implicit none class(psb_z_sparse_mat), intent(in) :: a character(len=5) :: res @@ -165,12 +635,11 @@ contains res = 'NULL' end if - end function sparse_get_fmt + end function psb_z_get_fmt function get_dupl(a) result(res) - use psb_error_mod implicit none class(psb_z_sparse_mat), intent(in) :: a integer :: res @@ -341,73 +810,33 @@ contains function get_nzeros(a) result(res) - use psb_error_mod implicit none class(psb_z_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_nzeros() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() end if end function get_nzeros function get_size(a) result(res) - use psb_error_mod + implicit none class(psb_z_sparse_mat), intent(in) :: a integer :: res - Integer :: err_act, info - character(len=20) :: name='get_size' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%get_size() - - call psb_erractionrestore(err_act) - return -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() end if - return end function get_size function get_nz_row(idx,a) result(res) - use psb_error_mod implicit none integer, intent(in) :: idx class(psb_z_sparse_mat), intent(in) :: a @@ -422,1504 +851,4 @@ contains end function get_nz_row - - !===================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine set_nrows(m,a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - integer, intent(in) :: m - Integer :: err_act, info - character(len=20) :: name='set_nrows' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_nrows(m) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_nrows - - subroutine set_ncols(n,a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_ncols(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_ncols - - - subroutine set_state(n,a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - call a%a%set_state(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_state - - - subroutine set_dupl(n,a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - integer, intent(in) :: n - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_dupl(n) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_dupl - - subroutine set_null(a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_null() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_null - - subroutine set_bld(a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_bld() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_bld - - subroutine set_upd(a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upd() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - - end subroutine set_upd - - subroutine set_asb(a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_asb() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_asb - - subroutine set_sorted(a,val) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_sorted(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_sorted - - subroutine set_triangle(a,val) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_triangle(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_triangle - - subroutine set_unit(a,val) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_unit(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_unit - - subroutine set_lower(a,val) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_lower(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_lower - - subroutine set_upper(a,val) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: val - Integer :: err_act, info - character(len=20) :: name='get_nzeros' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%set_upper(val) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine set_upper - - - !===================================== - ! - ! - ! - ! Data management - ! - ! - ! - ! - ! - !===================================== - - - subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_error_mod - implicit none - - integer, intent(in) :: iout - class(psb_z_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - Integer :: err_act, info - character(len=20) :: name='sparse_print' - logical, parameter :: debug=.false. - - info = 0 - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine sparse_print - - - - subroutine get_neigh(a,idx,neigh,n,info,lev) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable, intent(out) :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - - Integer :: err_act - character(len=20) :: name='get_neigh' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_neigh(idx,neigh,n,info,lev) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_neigh - - - subroutine csall(nr,nc,a,info,nz) - use psb_z_base_mat_mod - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(out) :: a - integer, intent(in) :: nr,nc - integer, intent(out) :: info - integer, intent(in), optional :: nz - - Integer :: err_act - character(len=20) :: name='csall' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - - info = 0 - allocate(psb_z_coo_sparse_mat :: a%a, stat=info) - if (info /= 0) then - info = 4000 - call psb_errpush(info, name) - goto 9999 - end if - call a%a%allocate(nr,nc,nz) - call a%set_bld() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csall - - subroutine reallocate_nz(nz,a) - use psb_error_mod - implicit none - integer, intent(in) :: nz - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='reallocate_nz' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reallocate(nz) - - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine reallocate_nz - - subroutine free(a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='free' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%free() - deallocate(a%a) - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine free - - subroutine trim(a) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='trim' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%trim() - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine trim - - - subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_z_base_mat_mod - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - - Integer :: err_act - character(len=20) :: name='csput' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.a%is_bld()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csput - - subroutine z_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod - implicit none - - class(psb_z_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine z_csgetptn - - subroutine z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod - implicit none - - class(psb_z_sparse_mat), intent(in) :: a - integer, intent(in) :: imin,imax - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - - call a%a%csget(imin,imax,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine z_csgetrow - - - - subroutine z_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod - implicit none - - class(psb_z_sparse_mat), intent(in) :: a - class(psb_z_sparse_mat), intent(out) :: b - integer, intent(in) :: imin,imax - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csget' - logical, parameter :: debug=.false. - type(psb_z_coo_sparse_mat), allocatable :: acoo - - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - - if (info == 0) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine z_csgetblk - - - - subroutine csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format - use psb_error_mod - use psb_const_mod - use psb_z_base_mat_mod - implicit none - - class(psb_z_sparse_mat), intent(in) :: a - class(psb_z_sparse_mat), intent(out) :: b - integer,intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - Integer :: err_act - character(len=20) :: name='csclip' - logical, parameter :: debug=.false. - type(psb_z_coo_sparse_mat), allocatable :: acoo - - info = 0 - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - allocate(acoo,stat=info) - if (info == 0) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine csclip - - - - subroutine z_cscnv(a,b,info,type,mold,upd,dupl) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - class(psb_z_sparse_mat), intent(out) :: b - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_z_base_sparse_mat), intent(in), optional :: mold - - - class(psb_z_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - call b%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call b%set_dupl(psb_dupl_def_) - end if - - if (count( (/present(mold),present(type) /)) > 1) then - info = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_z_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,b%a) - call b%set_asb() - call b%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine z_cscnv - - - subroutine z_cscnv_ip(a,info,type,mold,dupl) - use psb_error_mod - use psb_string_mod - implicit none - - class(psb_z_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_z_base_sparse_mat), intent(in), optional :: mold - - - class(psb_z_base_sparse_mat), allocatable :: altmp - Integer :: err_act - character(len=20) :: name='cscnv_ip' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - - if (a%is_null()) then - info = 1121 - 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 = 583 - call psb_errpush(info,name,a_err='TYPE, MOLD') - goto 9999 - end if - - if (present(mold)) then - - allocate(altmp, source=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 default - info = 136 - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(psb_z_csr_sparse_mat :: altmp, stat=info) - end if - - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug) write(0,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%mv_from_fmt(a%a, info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,a%a) - call a%set_asb() - call a%trim() - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine z_cscnv_ip - - subroutine z_mv_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_sparse_mat), intent(out) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer :: info - - allocate(a%a,source=b, stat=info) - call a%a%mv_from_fmt(b,info) - - return - end subroutine z_mv_from - - subroutine z_cp_from(a,b) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_sparse_mat), intent(out) :: a - class(psb_z_base_sparse_mat), intent(inout), allocatable :: b - Integer :: err_act, info - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end subroutine z_cp_from - - subroutine z_sparse_mat_move(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - class(psb_z_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='move_alloc' - logical, parameter :: debug=.false. - - info = 0 - call move_alloc(a%a,b%a) - - return - end subroutine z_sparse_mat_move - - subroutine z_sparse_mat_clone(a,b,info) - use psb_error_mod - use psb_string_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - class(psb_z_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='clone' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = 0 - - allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine z_sparse_mat_clone - - - subroutine reinit(a,clear) - use psb_error_mod - implicit none - - class(psb_z_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - Integer :: err_act, info - character(len=20) :: name='reinit' - - call psb_erractionsave(err_act) - if (a%is_null()) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%reinit(clear) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - - end subroutine reinit - - - !===================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - !===================================== - - - subroutine z_csmm(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csmm - - subroutine z_csmv(alpha,a,x,beta,y,info,trans) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans - Integer :: err_act - character(len=20) :: name='psb_csmv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_csmv - - subroutine z_cssm(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssm' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_cssm - - subroutine z_cssv(alpha,a,x,beta,y,info,trans,scale,d) - use psb_error_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer, intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - Integer :: err_act - character(len=20) :: name='psb_cssv' - logical, parameter :: debug=.false. - - info = 0 - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_cssv - - - function csnmi(a) result(res) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - - Integer :: err_act, info - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - res = a%a%csnmi() - - - return - -9999 continue - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end function csnmi - - - - subroutine get_diag(a,d,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%get_diag(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine get_diag - - subroutine z_scal(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_scal - - subroutine z_scals(d,a,info) - use psb_error_mod - use psb_const_mod - implicit none - class(psb_z_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='csnmi' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - endif - - call a%a%scal(d,info) - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_scals - - end module psb_z_mat_mod diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index 4b9d6463..fc8027ad 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -573,2276 +573,312 @@ module psi_mod end interface interface psi_cnv_dsc - module procedure psi_cnv_dsc + subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) + use psb_descriptor_type, only: psb_desc_type + integer, intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) + type(psb_desc_type), intent(inout) :: cdesc + integer, intent(out) :: info + end subroutine psi_cnv_dsc end interface interface psi_renum_index - module procedure psi_renum_index + subroutine psi_renum_index(iperm,idx,info) + integer, intent(out) :: info + integer, intent(in) :: iperm(:) + integer, intent(inout) :: idx(:) + end subroutine psi_renum_index end interface + interface psi_renum_idxmap + subroutine psi_renum_idxmap(nc,iperm,idxmap,info) + use psb_descriptor_type, only: psb_idxmap_type + integer, intent(out) :: info + integer, intent(in) :: nc,iperm(:) + type(psb_idxmap_type), intent(inout) :: idxmap + end subroutine psi_renum_idxmap + end interface + + interface psi_inner_cnv - module procedure psi_inner_cnv1, psi_inner_cnv2,& - & psi_inner_cnvs, psi_inner_cnvs2 -! & psi_inner_cnv1_mask, psi_inner_cnv2_mask,& + subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(inout) :: x + end subroutine psi_inner_cnvs + subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(in) :: x + integer, intent(out) :: y + end subroutine psi_inner_cnvs2 + subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) + integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer, intent(inout) :: x(:) + end subroutine psi_inner_cnv1 + subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) + integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in),optional :: mask(:) + integer, intent(in) :: x(:) + integer, intent(out) :: y(:) + end subroutine psi_inner_cnv2 end interface interface psi_ovrl_upd - module procedure psi_iovrl_updr1, psi_iovrl_updr2,& - & psi_sovrl_updr1, psi_sovrl_updr2, & - & psi_covrl_updr1, psi_covrl_updr2, & - & psi_dovrl_updr1, psi_dovrl_updr2, & - & psi_zovrl_updr1, psi_zovrl_updr2 + subroutine psi_iovrl_updr1(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + integer, intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_iovrl_updr1 + subroutine psi_iovrl_updr2(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + integer, intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_iovrl_updr2 + subroutine psi_sovrl_updr1(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_sovrl_updr1 + subroutine psi_sovrl_updr2(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_sovrl_updr2 + subroutine psi_dovrl_updr1(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_dovrl_updr1 + subroutine psi_dovrl_updr2(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_dovrl_updr2 + subroutine psi_covrl_updr1(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_covrl_updr1 + subroutine psi_covrl_updr2(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_covrl_updr2 + subroutine psi_zovrl_updr1(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_zovrl_updr1 + subroutine psi_zovrl_updr2(x,desc_a,update,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + end subroutine psi_zovrl_updr2 + end interface interface psi_ovrl_save - module procedure psi_iovrl_saver1, psi_iovrl_saver2,& - & psi_sovrl_saver1, psi_sovrl_saver2,& - & psi_covrl_saver1, psi_covrl_saver2,& - & psi_dovrl_saver1, psi_dovrl_saver2,& - & psi_zovrl_saver1, psi_zovrl_saver2 + subroutine psi_iovrl_saver1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + integer, intent(inout) :: x(:) + integer, allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_iovrl_saver1 + subroutine psi_iovrl_saver2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + integer, intent(inout) :: x(:,:) + integer, allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_iovrl_saver2 + subroutine psi_sovrl_saver1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_sovrl_saver1 + subroutine psi_sovrl_saver2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_sovrl_saver2 + subroutine psi_dovrl_saver1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_dovrl_saver1 + subroutine psi_dovrl_saver2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_dovrl_saver2 + subroutine psi_covrl_saver1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_covrl_saver1 + subroutine psi_covrl_saver2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_covrl_saver2 + subroutine psi_zovrl_saver1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_zovrl_saver1 + subroutine psi_zovrl_saver2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_zovrl_saver2 end interface interface psi_ovrl_restore - module procedure psi_iovrl_restrr1, psi_iovrl_restrr2,& - & psi_sovrl_restrr1, psi_sovrl_restrr2,& - & psi_covrl_restrr1, psi_covrl_restrr2,& - & psi_dovrl_restrr1, psi_dovrl_restrr2,& - & psi_zovrl_restrr1, psi_zovrl_restrr2 + subroutine psi_iovrl_restrr1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + integer, intent(inout) :: x(:) + integer :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_iovrl_restrr1 + subroutine psi_iovrl_restrr2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + integer, intent(inout) :: x(:,:) + integer :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_iovrl_restrr2 + subroutine psi_sovrl_restrr1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_sovrl_restrr1 + subroutine psi_sovrl_restrr2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_sovrl_restrr2 + subroutine psi_dovrl_restrr1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_dovrl_restrr1 + subroutine psi_dovrl_restrr2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_dovrl_restrr2 + subroutine psi_covrl_restrr1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_covrl_restrr1 + subroutine psi_covrl_restrr2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_covrl_restrr2 + subroutine psi_zovrl_restrr1(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_zovrl_restrr1 + subroutine psi_zovrl_restrr2(x,xs,desc_a,info) + use psb_const_mod + use psb_descriptor_type, only: psb_desc_type + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psi_zovrl_restrr2 end interface - -contains - - subroutine psi_renum_index(iperm,idx,info) - use psb_serial_mod - implicit none - - integer, intent(out) :: info - integer, intent(in) :: iperm(:) - integer, intent(inout) :: idx(:) - - integer :: i,j,k,nh - - i=1 - k=idx(i) - do while (k /= -1) - i = i+1 - nh = idx(i) - do j = i+1, i+nh - idx(j) = iperm(idx(j)) - enddo - i = i + nh + 1 - nh = idx(i) - do j = i+1, i+nh - idx(j) = iperm(idx(j)) - enddo - i = i + nh + 1 - k = idx(i) - enddo - - end subroutine psi_renum_index - - subroutine psi_renum_idxmap(nc,iperm,idxmap,info) - use psb_serial_mod - implicit none - - integer, intent(out) :: info - integer, intent(in) :: nc,iperm(:) - type(psb_idxmap_type), intent(inout) :: idxmap - - integer, allocatable :: itmp(:) - integer :: i,j,k,nh - - if (nc > size(iperm)) then - info = 2 - return - endif - - if (idxmap%state == psb_desc_large_) then - - allocate(itmp(size(idxmap%loc_to_glob)), stat=i) - if (i/=0) then - info = 4001 - return - end if - do i=1,nc - itmp(i) = idxmap%loc_to_glob(iperm(i)) - end do - do i=1, size(idxmap%glb_lc,1) - idxmap%glb_lc(i,2) = iperm(idxmap%glb_lc(i,2)) - end do - do i=1, nc - idxmap%loc_to_glob(i) = itmp(i) - end do - - else - - do i=1, nc - idxmap%glob_to_loc(idxmap%loc_to_glob(iperm(i))) = i - enddo - do i=1,size(idxmap%glob_to_loc) - j = idxmap%glob_to_loc(i) - if (j>0) then - idxmap%loc_to_glob(j) = i - endif - enddo - end if - - end subroutine psi_renum_idxmap + interface + subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) + integer, intent(in) :: me, ovrlap_elem(:,:) + integer, allocatable, intent(out) :: mst_idx(:) + integer, intent(out) :: info + end subroutine psi_bld_ovr_mst + end interface - subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) - - use psb_realloc_mod - implicit none - - ! ....scalars parameters.... - integer, intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) - type(psb_desc_type), intent(inout) :: cdesc - integer, intent(out) :: info - - ! ....local scalars.... - integer :: np,me - integer :: ictxt, err_act,nxch,nsnd,nrcv,j,k - ! ...local array... - integer, allocatable :: idx_out(:), tmp_mst_idx(:) - - ! ...parameters - integer :: debug_level, debug_unit - logical, parameter :: debug=.false. - character(len=20) :: name - - name='psi_bld_cdesc' - call psb_get_erraction(err_act) - debug_level = psb_get_debug_level() - debug_unit = psb_get_debug_unit() - - info = 0 - ictxt = cdesc%matrix_data(psb_ctxt_) - - call psb_info(ictxt,me,np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - - ! first the halo index - if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',& - & size(halo_in) - call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - call psb_move_alloc(idx_out,cdesc%halo_index,info) - cdesc%matrix_data(psb_thal_xch_) = nxch - cdesc%matrix_data(psb_thal_snd_) = nsnd - cdesc%matrix_data(psb_thal_rcv_) = nrcv - - if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo' - if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' - - - ! then ext index - if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' - call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - call psb_move_alloc(idx_out,cdesc%ext_index,info) - cdesc%matrix_data(psb_text_xch_) = nxch - cdesc%matrix_data(psb_text_snd_) = nsnd - cdesc%matrix_data(psb_text_rcv_) = nrcv - - if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext' - if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap' - - ! then the overlap index - call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - call psb_move_alloc(idx_out,cdesc%ovrlap_index,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_move_alloc') - goto 9999 - end if - - cdesc%matrix_data(psb_tovr_xch_) = nxch - cdesc%matrix_data(psb_tovr_snd_) = nsnd - cdesc%matrix_data(psb_tovr_rcv_) = nrcv - - ! next ovrlap_elem - if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem' - call psi_crea_ovr_elem(me,cdesc%ovrlap_index,cdesc%ovrlap_elem,info) - if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem' - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_ovr_elem') - goto 9999 - end if - ! Extract ovr_mst_idx from ovrlap_elem - if (debug_level>0) write(debug_unit,*) me,'Calling bld_ovr_mst' - call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info) - if (info == 0) call psi_crea_index(cdesc,& - & tmp_mst_idx,idx_out,.false.,nxch,nsnd,nrcv,info) - if (debug_level>0) write(debug_unit,*) me,'Done crea_indx' - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_bld_ovr_mst') - goto 9999 - end if - call psb_move_alloc(idx_out,cdesc%ovr_mst_idx,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_move_alloc') - goto 9999 - end if - - cdesc%matrix_data(psb_tmov_xch_) = nxch - cdesc%matrix_data(psb_tmov_snd_) = nsnd - cdesc%matrix_data(psb_tmov_rcv_) = nrcv - - ! finally bnd_elem - call psi_crea_bnd_elem(idx_out,cdesc,info) - if (info == 0) call psb_move_alloc(idx_out,cdesc%bnd_elem,info) - - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') - goto 9999 - end if - if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - - end subroutine psi_cnv_dsc - - - subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) - integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer, intent(inout) :: x - - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - - key = x - ih = iand(key,hashmask) - idx = hashv(ih) - nh = hashv(ih+1) - hashv(ih) - if (nh > 0) then - tmp = -1 - lb = idx - ub = idx+nh-1 - do - if (lb>ub) exit - lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then - tmp = lm - exit - else if (key 0) then - x = glb_lc(tmp,2) - else - x = tmp - end if - end subroutine psi_inner_cnvs - - subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) - integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer, intent(in) :: x - integer, intent(out) :: y - - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - - key = x - ih = iand(key,hashmask) - idx = hashv(ih) - nh = hashv(ih+1) - hashv(ih) - if (nh > 0) then - tmp = -1 - lb = idx - ub = idx+nh-1 - do - if (lb>ub) exit - lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then - tmp = lm - exit - else if (key 0) then - y = glb_lc(tmp,2) - else - y = tmp - end if - end subroutine psi_inner_cnvs2 - - - subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) - integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) - logical, intent(in), optional :: mask(:) - integer, intent(inout) :: x(:) - - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - if (present(mask)) then - do i=1, n - if (mask(i)) then - key = x(i) - ih = iand(key,hashmask) - idx = hashv(ih) - nh = hashv(ih+1) - hashv(ih) - if (nh > 0) then - tmp = -1 - lb = idx - ub = idx+nh-1 - do - if (lb>ub) exit - lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then - tmp = lm - exit - else if (key 0) then - x(i) = glb_lc(tmp,2) - else - x(i) = tmp - end if - end if - end do - else - do i=1, n - key = x(i) - ih = iand(key,hashmask) - idx = hashv(ih) - nh = hashv(ih+1) - hashv(ih) - if (nh > 0) then - tmp = -1 - lb = idx - ub = idx+nh-1 - do - if (lb>ub) exit - lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then - tmp = lm - exit - else if (key 0) then - x(i) = glb_lc(tmp,2) - else - x(i) = tmp - end if - end do - end if - end subroutine psi_inner_cnv1 - - subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) - integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) - logical, intent(in),optional :: mask(:) - integer, intent(in) :: x(:) - integer, intent(out) :: y(:) - - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - if (present(mask)) then - do i=1, n - if (mask(i)) then - key = x(i) - ih = iand(key,hashmask) - if (ih > ubound(hashv,1) ) then - write(0,*) ' In inner cnv: ',ih,ubound(hashv) - end if - idx = hashv(ih) - nh = hashv(ih+1) - hashv(ih) - if (nh > 0) then - tmp = -1 - lb = idx - ub = idx+nh-1 - do - if (lb>ub) exit - lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then - tmp = lm - exit - else if (key 0) then - y(i) = glb_lc(tmp,2) - else - y(i) = tmp - end if - end if - end do - else - do i=1, n - key = x(i) - ih = iand(key,hashmask) - if (ih > ubound(hashv,1) ) then - write(0,*) ' In inner cnv: ',ih,ubound(hashv) - end if - idx = hashv(ih) - nh = hashv(ih+1) - hashv(ih) - if (nh > 0) then - tmp = -1 - lb = idx - ub = idx+nh-1 - do - if (lb>ub) exit - lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then - tmp = lm - exit - else if (key 0) then - y(i) = glb_lc(tmp,2) - else - y(i) = tmp - end if - end do - end if - end subroutine psi_inner_cnv2 - - subroutine psi_sovrl_updr1(x,desc_a,update,info) - - implicit none - - real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_sovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_sovrl_updr1 - - - subroutine psi_sovrl_updr2(x,desc_a,update,info) - - implicit none - - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_sovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_sovrl_updr2 - - subroutine psi_dovrl_updr1(x,desc_a,update,info) - - implicit none - - real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_dovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_dovrl_updr1 - - - subroutine psi_dovrl_updr2(x,desc_a,update,info) - - implicit none - - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_dovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_dovrl_updr2 - - subroutine psi_covrl_updr1(x,desc_a,update,info) - - implicit none - - complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_covrl_updr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_covrl_updr1 - - - subroutine psi_covrl_updr2(x,desc_a,update,info) - - implicit none - - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_covrl_updr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_covrl_updr2 - - subroutine psi_zovrl_updr1(x,desc_a,update,info) - - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_zovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_zovrl_updr1 - - - subroutine psi_zovrl_updr2(x,desc_a,update,info) - - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_zovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_zovrl_updr2 - - subroutine psi_iovrl_updr1(x,desc_a,update,info) - - implicit none - - integer, intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_iovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - ! Square root does not make sense here -!!$ case(psb_square_root_) -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ x(idx) = x(idx)/sqrt(real(ndm)) -!!$ end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = izero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_iovrl_updr1 - - - subroutine psi_iovrl_updr2(x,desc_a,update,info) - - implicit none - - integer, intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(in) :: update - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, ndm - character(len=20) :: name, ch_err - - name='psi_iovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - ! Square root does not make sense here -!!$ case(psb_square_root_) -!!$ do i=1,size(desc_a%ovrlap_elem,1) -!!$ idx = desc_a%ovrlap_elem(i,1) -!!$ ndm = desc_a%ovrlap_elem(i,2) -!!$ x(idx,:) = x(idx,:)/sqrt(real(ndm)) -!!$ end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = izero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = 70 - call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_iovrl_updr2 - - - subroutine psi_sovrl_saver1(x,xs,desc_a,info) - use psb_realloc_mod - - implicit none - - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_sovrl_saver1 - - subroutine psi_sovrl_restrr1(x,xs,desc_a,info) - - implicit none - - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_sovrl_restrr1 - - - subroutine psi_sovrl_saver2(x,xs,desc_a,info) - use psb_realloc_mod - - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_sovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_sovrl_saver2 - - subroutine psi_sovrl_restrr2(x,xs,desc_a,info) - - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = 4001 - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_sovrl_restrr2 - - - subroutine psi_dovrl_saver1(x,xs,desc_a,info) - use psb_realloc_mod - - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_dovrl_saver1 - - subroutine psi_dovrl_restrr1(x,xs,desc_a,info) - - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_dovrl_restrr1 - - - subroutine psi_dovrl_saver2(x,xs,desc_a,info) - use psb_realloc_mod - - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_dovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_dovrl_saver2 - - subroutine psi_dovrl_restrr2(x,xs,desc_a,info) - - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = 4001 - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_dovrl_restrr2 - - subroutine psi_covrl_saver1(x,xs,desc_a,info) - use psb_realloc_mod - - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_saver1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_covrl_saver1 - - subroutine psi_covrl_restrr1(x,xs,desc_a,info) - - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_covrl_restrr1 - - - subroutine psi_covrl_saver2(x,xs,desc_a,info) - use psb_realloc_mod - - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_covrl_saver2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_covrl_saver2 - - subroutine psi_covrl_restrr2(x,xs,desc_a,info) - - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = 4001 - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_covrl_restrr2 - - - subroutine psi_zovrl_saver1(x,xs,desc_a,info) - - use psb_realloc_mod - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_zovrl_saver1 - - subroutine psi_zovrl_restrr1(x,xs,desc_a,info) - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_zovrl_restrr1 - - - subroutine psi_zovrl_saver2(x,xs,desc_a,info) - - use psb_realloc_mod - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_zovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_zovrl_saver2 - - subroutine psi_zovrl_restrr2(x,xs,desc_a,info) - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = 4001 - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_zovrl_restrr2 - - - subroutine psi_iovrl_saver1(x,xs,desc_a,info) - - use psb_realloc_mod - - implicit none - - integer, intent(inout) :: x(:) - integer, allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_iovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_iovrl_saver1 - - subroutine psi_iovrl_restrr1(x,xs,desc_a,info) - - implicit none - - integer, intent(inout) :: x(:) - integer :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_iovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_iovrl_restrr1 - - - subroutine psi_iovrl_saver2(x,xs,desc_a,info) - use psb_descriptor_type - use psb_const_mod - use psb_error_mod - use psb_realloc_mod - use psb_penv_mod - implicit none - - integer, intent(inout) :: x(:,:) - integer, allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_iovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_iovrl_saver2 - - subroutine psi_iovrl_restrr2(x,xs,desc_a,info) - - implicit none - - integer, intent(inout) :: x(:,:) - integer :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - - ! locals - integer :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_iovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - ictxt = psb_cd_get_context(desc_a) - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = 4001 - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - end subroutine psi_iovrl_restrr2 - - subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) - - use psb_realloc_mod - implicit none - - ! ....scalars parameters.... - integer, intent(in) :: me, ovrlap_elem(:,:) - integer, allocatable, intent(out) :: mst_idx(:) - integer, intent(out) :: info - - integer :: i, j, proc, nov,isz, ip, err_act, idx - character(len=20) :: name - - name='psi_bld_ovr_mst' - call psb_get_erraction(err_act) - - nov = size(ovrlap_elem,1) - isz = 3*nov+1 - call psb_realloc(isz,mst_idx,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='reallocate') - goto 9999 - end if - mst_idx = -1 - j = 1 - do i=1, nov - proc = ovrlap_elem(i,3) - if (me /= proc) then - idx = ovrlap_elem(i,1) - mst_idx(j+0) = proc - mst_idx(j+1) = 1 - mst_idx(j+2) = idx - j = j + 3 - end if - end do - mst_idx(j) = -1 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psi_bld_ovr_mst - end module psi_mod + diff --git a/base/modules/psi_serial_mod.f90 b/base/modules/psi_serial_mod.f90 index 74e103ed..64bb8a82 100644 --- a/base/modules/psi_serial_mod.f90 +++ b/base/modules/psi_serial_mod.f90 @@ -31,30 +31,6 @@ !!$ module psi_serial_mod - - interface psi_gth - module procedure & - & psi_igthv, psi_sgthv, psi_cgthv, psi_dgthv, psi_zgthv,& - & psi_igthzv, psi_sgthzv, psi_cgthzv, psi_dgthzv, psi_zgthzv,& - & psi_igthzmv, psi_sgthzmv, psi_cgthzmv, psi_dgthzmv, psi_zgthzmv - end interface - - interface psi_sct - module procedure psi_isctmv, psi_isctv,& - & psi_ssctmv, psi_ssctv,& - & psi_csctmv, psi_csctv,& - & psi_dsctmv, psi_dsctv,& - & psi_zsctmv, psi_zsctv - end interface - - interface psb_geaxpby - module procedure psi_saxpbyv, psi_saxpby, & - & psi_daxpbyv, psi_daxpby, & - & psi_caxpbyv, psi_caxpby, & - & psi_zaxpbyv, psi_zaxpby - end interface - - interface psb_gelp ! 2-D version subroutine psb_sgelp(trans,iperm,x,info) @@ -122,1219 +98,205 @@ module psi_serial_mod end interface -contains - - - subroutine psi_igthv(n,idx,alpha,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - integer :: x(:), y(:), alpha, beta - - ! Locals - integer :: i - if (beta == izero) then - if (alpha == izero) then - do i=1,n - y(i) = izero - end do - else if (alpha == ione) then - do i=1,n - y(i) = x(idx(i)) - end do - else if (alpha == -ione) then - do i=1,n - y(i) = -x(idx(i)) - end do - else - do i=1,n - y(i) = alpha*x(idx(i)) - end do - end if - else - if (beta == ione) then - ! Do nothing - else if (beta == -ione) then - y(1:n) = -y(1:n) - else - y(1:n) = beta*y(1:n) - end if - - if (alpha == izero) then - ! do nothing - else if (alpha == ione) then - do i=1,n - y(i) = y(i) + x(idx(i)) - end do - else if (alpha == -ione) then - do i=1,n - y(i) = y(i) - x(idx(i)) - end do - else - do i=1,n - y(i) = y(i) + alpha*x(idx(i)) - end do - end if - end if - - end subroutine psi_igthv - - subroutine psi_sgthv(n,idx,alpha,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(psb_spk_) :: x(:), y(:), alpha, beta - - ! Locals - integer :: i - if (beta == szero) then - if (alpha == szero) then - do i=1,n - y(i) = szero - end do - else if (alpha == sone) then - do i=1,n - y(i) = x(idx(i)) - end do - else if (alpha == -sone) then - do i=1,n - y(i) = -x(idx(i)) - end do - else - do i=1,n - y(i) = alpha*x(idx(i)) - end do - end if - else - if (beta == sone) then - ! Do nothing - else if (beta == -sone) then - y(1:n) = -y(1:n) - else - y(1:n) = beta*y(1:n) - end if - - if (alpha == szero) then - ! do nothing - else if (alpha == sone) then - do i=1,n - y(i) = y(i) + x(idx(i)) - end do - else if (alpha == -sone) then - do i=1,n - y(i) = y(i) - x(idx(i)) - end do - else - do i=1,n - y(i) = y(i) + alpha*x(idx(i)) - end do - end if - end if - - end subroutine psi_sgthv - - subroutine psi_dgthv(n,idx,alpha,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(psb_dpk_) :: x(:), y(:), alpha, beta - - ! Locals - integer :: i - if (beta == dzero) then - if (alpha == dzero) then - do i=1,n - y(i) = dzero - end do - else if (alpha == done) then - do i=1,n - y(i) = x(idx(i)) - end do - else if (alpha == -done) then - do i=1,n - y(i) = -x(idx(i)) - end do - else - do i=1,n - y(i) = alpha*x(idx(i)) - end do - end if - else - if (beta == done) then - ! Do nothing - else if (beta == -done) then - y(1:n) = -y(1:n) - else - y(1:n) = beta*y(1:n) - end if - - if (alpha == dzero) then - ! do nothing - else if (alpha == done) then - do i=1,n - y(i) = y(i) + x(idx(i)) - end do - else if (alpha == -done) then - do i=1,n - y(i) = y(i) - x(idx(i)) - end do - else - do i=1,n - y(i) = y(i) + alpha*x(idx(i)) - end do - end if - end if - - end subroutine psi_dgthv - - subroutine psi_cgthv(n,idx,alpha,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(psb_spk_) :: x(:), y(:),alpha,beta - - ! Locals - integer :: i - if (beta == czero) then - if (alpha == czero) then - do i=1,n - y(i) = czero - end do - else if (alpha == cone) then - do i=1,n - y(i) = x(idx(i)) - end do - else if (alpha == -cone) then - do i=1,n - y(i) = -x(idx(i)) - end do - else - do i=1,n - y(i) = alpha*x(idx(i)) - end do - end if - else - if (beta == cone) then - ! Do nothing - else if (beta == -cone) then - y(1:n) = -y(1:n) - else - y(1:n) = beta*y(1:n) - end if - - if (alpha == czero) then - ! do nothing - else if (alpha == cone) then - do i=1,n - y(i) = y(i) + x(idx(i)) - end do - else if (alpha == -cone) then - do i=1,n - y(i) = y(i) - x(idx(i)) - end do - else - do i=1,n - y(i) = y(i) + alpha*x(idx(i)) - end do - end if - end if - - end subroutine psi_cgthv - - subroutine psi_zgthv(n,idx,alpha,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(psb_dpk_) :: x(:), y(:),alpha,beta - - ! Locals - integer :: i - if (beta == zzero) then - if (alpha == zzero) then - do i=1,n - y(i) = zzero - end do - else if (alpha == zone) then - do i=1,n - y(i) = x(idx(i)) - end do - else if (alpha == -zone) then - do i=1,n - y(i) = -x(idx(i)) - end do - else - do i=1,n - y(i) = alpha*x(idx(i)) - end do - end if - else - if (beta == zone) then - ! Do nothing - else if (beta == -zone) then - y(1:n) = -y(1:n) - else - y(1:n) = beta*y(1:n) - end if - - if (alpha == zzero) then - ! do nothing - else if (alpha == zone) then - do i=1,n - y(i) = y(i) + x(idx(i)) - end do - else if (alpha == -zone) then - do i=1,n - y(i) = y(i) - x(idx(i)) - end do - else - do i=1,n - y(i) = y(i) + alpha*x(idx(i)) - end do - end if - end if - - end subroutine psi_zgthv - - - - subroutine psi_sgthzmv(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - real(psb_spk_) :: x(:,:), y(:) - - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(pt)=x(idx(i),j) - end do - end do - - end subroutine psi_sgthzmv - - subroutine psi_dgthzmv(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - real(psb_dpk_) :: x(:,:), y(:) - - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(pt)=x(idx(i),j) - end do - end do - - end subroutine psi_dgthzmv - - - subroutine psi_igthzmv(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - integer :: x(:,:), y(:) - - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(pt)=x(idx(i),j) - end do - end do - - end subroutine psi_igthzmv - - - subroutine psi_cgthzmv(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - complex(psb_spk_) :: x(:,:), y(:) - - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(pt)=x(idx(i),j) - end do - end do - - end subroutine psi_cgthzmv - - subroutine psi_zgthzmv(n,k,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - complex(psb_dpk_) :: x(:,:), y(:) - - ! Locals - integer :: i, j, pt - - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(pt)=x(idx(i),j) - end do - end do - - end subroutine psi_zgthzmv - - subroutine psi_sgthzv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(psb_spk_) :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_sgthzv - - subroutine psi_dgthzv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(psb_dpk_) :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_dgthzv - - subroutine psi_igthzv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - integer :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_igthzv - - subroutine psi_cgthzv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(psb_spk_) :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_cgthzv - - subroutine psi_zgthzv(n,idx,x,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(psb_dpk_) :: x(:), y(:) - - ! Locals - integer :: i - - do i=1,n - y(i)=x(idx(i)) - end do - - end subroutine psi_zgthzv - - subroutine psi_ssctmv(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - real(psb_spk_) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == szero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == sone) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - end do - else - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) - end do - end do - end if - end subroutine psi_ssctmv - - subroutine psi_ssctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(psb_spk_) :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == szero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == sone) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i)) - end do - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - end if - end subroutine psi_ssctv - - - subroutine psi_dsctmv(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - real(psb_dpk_) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == dzero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == done) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - end do - else - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) - end do - end do - end if - end subroutine psi_dsctmv - - subroutine psi_dsctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - real(psb_dpk_) :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == dzero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == done) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i)) - end do - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - end if - end subroutine psi_dsctv - - subroutine psi_isctmv(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - integer :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == izero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == ione) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - end do - else - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) - end do - end do - end if - end subroutine psi_isctmv - - subroutine psi_isctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - integer :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == izero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == ione) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if - end subroutine psi_isctv - - subroutine psi_csctmv(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - complex(psb_spk_) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == czero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == cone) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - end do - else - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) - end do - end do - end if - end subroutine psi_csctmv - - - subroutine psi_csctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(psb_spk_) :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == czero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == cone) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if - end subroutine psi_csctv - - subroutine psi_zsctmv(n,k,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, k, idx(:) - complex(psb_dpk_) :: beta, x(:), y(:,:) - - ! Locals - integer :: i, j, pt - - if (beta == zzero) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = x(pt) - end do - end do - else if (beta == zone) then - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = y(idx(i),j)+x(pt) - end do - end do - else - pt=0 - do j=1,k - do i=1,n - pt=pt+1 - y(idx(i),j) = beta*y(idx(i),j)+x(pt) - end do - end do - end if - end subroutine psi_zsctmv - - - subroutine psi_zsctv(n,idx,x,beta,y) - - use psb_const_mod - implicit none - - integer :: n, idx(:) - complex(psb_dpk_) :: beta, x(:), y(:) - - ! Locals - integer :: i - - if (beta == zzero) then - do i=1,n - y(idx(i)) = x(i) - end do - else if (beta == zone) then - do i=1,n - y(idx(i)) = y(idx(i))+x(i) - end do - else - do i=1,n - y(idx(i)) = beta*y(idx(i))+x(i) - end do - end if - end subroutine psi_zsctv - - - subroutine psi_saxpbyv(m,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - - integer, intent(in) :: m - real(psb_spk_), intent (in) :: x(:) - real(psb_spk_), intent (inout) :: y(:) - real(psb_spk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (size(x) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) - goto 9999 - end if - if (size(y) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) - goto 9999 - end if - - if (m>0) call saxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psi_saxpbyv - subroutine psi_saxpby(m,n,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m, n - real(psb_spk_), intent (in) :: x(:,:) - real(psb_spk_), intent (inout) :: y(:,:) - real(psb_spk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) - goto 9999 - end if - if (size(x,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) - goto 9999 - end if - if (size(y,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) - goto 9999 - end if - - if ((m>0).and.(n>0)) call saxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psi_saxpby - - subroutine psi_daxpbyv(m,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m - real(psb_dpk_), intent (in) :: x(:) - real(psb_dpk_), intent (inout) :: y(:) - real(psb_dpk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (size(x) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) - goto 9999 - end if - if (size(y) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) - goto 9999 - end if - - if (m>0) call daxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psi_daxpbyv - subroutine psi_daxpby(m,n,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m, n - real(psb_dpk_), intent (in) :: x(:,:) - real(psb_dpk_), intent (inout) :: y(:,:) - real(psb_dpk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) - goto 9999 - end if - if (size(x,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) - goto 9999 - end if - if (size(y,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) - goto 9999 - end if - - if ((m>0).and.(n>0)) call daxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psi_daxpby - - subroutine psi_caxpbyv(m,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m - complex(psb_spk_), intent (in) :: x(:) - complex(psb_spk_), intent (inout) :: y(:) - complex(psb_spk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (size(x) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) - goto 9999 - end if - if (size(y) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) - goto 9999 - end if - - if (m>0) call caxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psi_caxpbyv - subroutine psi_caxpby(m,n,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m, n - complex(psb_spk_), intent (in) :: x(:,:) - complex(psb_spk_), intent (inout) :: y(:,:) - complex(psb_spk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) - goto 9999 - end if - if (size(x,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) - goto 9999 - end if - if (size(y,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) - goto 9999 - end if - - if ((m>0).and.(n>0)) call caxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psi_caxpby - - subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m - complex(psb_dpk_), intent (in) :: x(:) - complex(psb_dpk_), intent (inout) :: y(:) - complex(psb_dpk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (size(x) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) - goto 9999 - end if - if (size(y) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) - goto 9999 - end if - - if (m>0) call zaxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return + interface psi_gth + subroutine psi_igthv(n,idx,alpha,x,beta,y) + integer :: n, idx(:) + integer :: x(:), y(:), alpha, beta + end subroutine psi_igthv + subroutine psi_sgthv(n,idx,alpha,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + real(psb_spk_) :: x(:), y(:), alpha, beta + end subroutine psi_sgthv + subroutine psi_dgthv(n,idx,alpha,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + real(psb_dpk_) :: x(:), y(:), alpha, beta + end subroutine psi_dgthv + subroutine psi_cgthv(n,idx,alpha,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + complex(psb_spk_) :: x(:), y(:),alpha,beta + end subroutine psi_cgthv + subroutine psi_zgthv(n,idx,alpha,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + complex(psb_dpk_) :: x(:), y(:),alpha,beta + end subroutine psi_zgthv + subroutine psi_sgthzmv(n,k,idx,x,y) + use psb_const_mod + integer :: n, k, idx(:) + real(psb_spk_) :: x(:,:), y(:) + end subroutine psi_sgthzmv + subroutine psi_dgthzmv(n,k,idx,x,y) + use psb_const_mod + integer :: n, k, idx(:) + real(psb_dpk_) :: x(:,:), y(:) + end subroutine psi_dgthzmv + subroutine psi_igthzmv(n,k,idx,x,y) + use psb_const_mod + integer :: n, k, idx(:) + integer :: x(:,:), y(:) + end subroutine psi_igthzmv + subroutine psi_cgthzmv(n,k,idx,x,y) + use psb_const_mod + integer :: n, k, idx(:) + complex(psb_spk_) :: x(:,:), y(:) + end subroutine psi_cgthzmv + subroutine psi_zgthzmv(n,k,idx,x,y) + use psb_const_mod + integer :: n, k, idx(:) + complex(psb_dpk_) :: x(:,:), y(:) + end subroutine psi_zgthzmv + subroutine psi_sgthzv(n,idx,x,y) + use psb_const_mod + integer :: n, idx(:) + real(psb_spk_) :: x(:), y(:) + end subroutine psi_sgthzv + subroutine psi_dgthzv(n,idx,x,y) + use psb_const_mod + integer :: n, idx(:) + real(psb_dpk_) :: x(:), y(:) + end subroutine psi_dgthzv + subroutine psi_igthzv(n,idx,x,y) + use psb_const_mod + integer :: n, idx(:) + integer :: x(:), y(:) + end subroutine psi_igthzv + subroutine psi_cgthzv(n,idx,x,y) + use psb_const_mod + integer :: n, idx(:) + complex(psb_spk_) :: x(:), y(:) + end subroutine psi_cgthzv + subroutine psi_zgthzv(n,idx,x,y) + use psb_const_mod + integer :: n, idx(:) + complex(psb_dpk_) :: x(:), y(:) + end subroutine psi_zgthzv + end interface -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine psi_zaxpbyv - subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) - use psb_const_mod - use psb_error_mod - implicit none - integer, intent(in) :: m, n - complex(psb_dpk_), intent (in) :: x(:,:) - complex(psb_dpk_), intent (inout) :: y(:,:) - complex(psb_dpk_), intent (in) :: alpha, beta - integer, intent(out) :: info - integer :: err_act - character(len=20) :: name, ch_err - - name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - if (m < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) - goto 9999 - end if - if (n < 0) then - info = 10 - call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) - goto 9999 - end if - if (size(x,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) - goto 9999 - end if - if (size(y,1) < m) then - info = 36 - call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) - goto 9999 - end if - if ((m>0).and.(n>0)) call zaxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) - - call psb_erractionrestore(err_act) - return + interface psi_sct + subroutine psi_ssctmv(n,k,idx,x,beta,y) + use psb_const_mod + integer :: n, k, idx(:) + real(psb_spk_) :: beta, x(:), y(:,:) + end subroutine psi_ssctmv + subroutine psi_ssctv(n,idx,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + real(psb_spk_) :: beta, x(:), y(:) + end subroutine psi_ssctv + subroutine psi_dsctmv(n,k,idx,x,beta,y) + use psb_const_mod + integer :: n, k, idx(:) + real(psb_dpk_) :: beta, x(:), y(:,:) + end subroutine psi_dsctmv + subroutine psi_dsctv(n,idx,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + real(psb_dpk_) :: beta, x(:), y(:) + end subroutine psi_dsctv + subroutine psi_isctmv(n,k,idx,x,beta,y) + use psb_const_mod + integer :: n, k, idx(:) + integer :: beta, x(:), y(:,:) + end subroutine psi_isctmv + subroutine psi_isctv(n,idx,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + integer :: beta, x(:), y(:) + end subroutine psi_isctv + subroutine psi_csctmv(n,k,idx,x,beta,y) + use psb_const_mod + integer :: n, k, idx(:) + complex(psb_spk_) :: beta, x(:), y(:,:) + end subroutine psi_csctmv + subroutine psi_csctv(n,idx,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + complex(psb_spk_) :: beta, x(:), y(:) + end subroutine psi_csctv + subroutine psi_zsctmv(n,k,idx,x,beta,y) + use psb_const_mod + integer :: n, k, idx(:) + complex(psb_dpk_) :: beta, x(:), y(:,:) + end subroutine psi_zsctmv + subroutine psi_zsctv(n,idx,x,beta,y) + use psb_const_mod + integer :: n, idx(:) + complex(psb_dpk_) :: beta, x(:), y(:) + end subroutine psi_zsctv + end interface -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine psi_zaxpby + interface psb_geaxpby + subroutine psi_saxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m + real(psb_spk_), intent (in) :: x(:) + real(psb_spk_), intent (inout) :: y(:) + real(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_saxpbyv + subroutine psi_saxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m, n + real(psb_spk_), intent (in) :: x(:,:) + real(psb_spk_), intent (inout) :: y(:,:) + real(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_saxpby + subroutine psi_daxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m + real(psb_dpk_), intent (in) :: x(:) + real(psb_dpk_), intent (inout) :: y(:) + real(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_daxpbyv + subroutine psi_daxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m, n + real(psb_dpk_), intent (in) :: x(:,:) + real(psb_dpk_), intent (inout) :: y(:,:) + real(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_daxpby + subroutine psi_caxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m + complex(psb_spk_), intent (in) :: x(:) + complex(psb_spk_), intent (inout) :: y(:) + complex(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_caxpbyv + subroutine psi_caxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + implicit none + integer, intent(in) :: m, n + complex(psb_spk_), intent (in) :: x(:,:) + complex(psb_spk_), intent (inout) :: y(:,:) + complex(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_caxpby + subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m + complex(psb_dpk_), intent (in) :: x(:) + complex(psb_dpk_), intent (inout) :: y(:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_zaxpbyv + subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + integer, intent(in) :: m, n + complex(psb_dpk_), intent (in) :: x(:,:) + complex(psb_dpk_), intent (inout) :: y(:,:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + end subroutine psi_zaxpby + end interface end module psi_serial_mod diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index 1274e48d..9364d0ee 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -90,7 +90,7 @@ function psb_cnrmi(a,desc_a,info) end if if ((m /= 0).and.(n /= 0)) then - nrmi = psb_csnmi(a) + nrmi = a%csnmi() if(info /= 0) then info=4010 ch_err='psb_csnmi' diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 4e51e139..123016b9 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -95,7 +95,7 @@ function psb_dnrmi(a,desc_a,info) end if if ((m /= 0).and.(n /= 0)) then - nrmi = psb_csnmi(a) + nrmi = a%csnmi() if(info /= 0) then info=4010 ch_err='psb_csnmi' diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index 83ffb218..82316789 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -95,7 +95,7 @@ function psb_snrmi(a,desc_a,info) end if if ((m /= 0).and.(n /= 0)) then - nrmi = psb_csnmi(a) + nrmi = a%csnmi() if(info /= 0) then info=4010 ch_err='psb_csnmi' diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 7851420a..2fdc0cdc 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -95,7 +95,7 @@ function psb_znrmi(a,desc_a,info) end if if ((m /= 0).and.(n /= 0)) then - nrmi = psb_csnmi(a) + nrmi = a%csnmi() if(info /= 0) then info=4010 ch_err='psb_csnmi' diff --git a/base/serial/Makefile b/base/serial/Makefile index 9fe0a285..f24ceef0 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -1,7 +1,7 @@ include ../../Make.inc -FOBJS = psb_lsame.o \ +FOBJS = psb_lsame.o psi_serial_impl.o psi_impl.o psb_sort_impl.o \ psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \ psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \ psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o diff --git a/base/serial/f03/Makefile b/base/serial/f03/Makefile index 8244430f..68d82f50 100644 --- a/base/serial/f03/Makefile +++ b/base/serial/f03/Makefile @@ -3,11 +3,13 @@ include ../../../Make.inc # # The object files # -FOBJS = psb_s_csr_impl.o psb_c_csr_impl.o psb_d_csr_impl.o psb_z_csr_impl.o\ - psb_s_coo_impl.o psb_c_coo_impl.o psb_d_coo_impl.o psb_z_coo_impl.o\ - psb_s_csc_impl.o psb_c_csc_impl.o psb_d_csc_impl.o psb_z_csc_impl.o +BOBJS=psb_base_mat_impl.o psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o +SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o +DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o +COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o +ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o -OBJS=$(FOBJS) +OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) # # Where the library should go, and how it is called. @@ -30,6 +32,9 @@ lib: $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) +# A bit excessive, but safe +$(OBJS): $(MODDIR)/psb_sparse_mod.o + clean: cleanobjs veryclean: cleanobjs diff --git a/base/serial/f03/psb_base_mat_impl.f03 b/base/serial/f03/psb_base_mat_impl.f03 new file mode 100644 index 00000000..39526adb --- /dev/null +++ b/base/serial/f03/psb_base_mat_impl.f03 @@ -0,0 +1,337 @@ +function psb_base_get_nz_row(idx,a) result(res) + use psb_error_mod + use psb_base_mat_mod, psb_protect_name => psb_base_get_nz_row + implicit none + integer, intent(in) :: idx + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + character(len=20) :: name='base_get_nz_row' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end function psb_base_get_nz_row + +function psb_base_get_nzeros(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_base_get_nzeros + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + character(len=20) :: name='base_get_nzeros' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end function psb_base_get_nzeros + +function psb_base_get_size(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_base_get_size + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end function psb_base_get_size + +subroutine psb_base_reinit(a,clear) + use psb_base_mat_mod, psb_protect_name => psb_base_reinit + use psb_error_mod + implicit none + + class(psb_base_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = 700 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_reinit + +subroutine psb_base_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_base_mat_mod, psb_protect_name => psb_base_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = 700 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_sparse_print + +subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_base_mat_mod, psb_protect_name => psb_base_csgetptn + implicit none + + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_csgetptn + +subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) + use psb_base_mat_mod, psb_protect_name => psb_base_get_neigh + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + integer :: lev_, i, nl, ifl,ill,& + & n1, err_act, nn, nidx,ntl,ma + integer, allocatable :: ia(:), ja(:) + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if(present(lev)) then + lev_ = lev + else + lev_=1 + end if + ! Turns out we can write get_neigh at this + ! level + n = 0 + ma = a%get_nrows() + call a%csget(idx,idx,n,ia,ja,info) + if (info == 0) call psb_realloc(n,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + neigh(1:n) = ja(1:n) + ifl = 1 + ill = n + do nl = 2, lev_ + n1 = ill - ifl + 1 + call psb_ensure_size(ill+n1*n1,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + ntl = 0 + do i=ifl,ill + nidx=neigh(i) + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then + call a%csget(nidx,nidx,nn,ia,ja,info) + if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) + ntl = ntl+nn + end if + end do + call psb_msort_unique(neigh(ill+1:ill+ntl),nn) + ifl = ill + 1 + ill = ill + nn + end do + call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_) + n = nn + + call psb_erractionrestore(err_act) + return + +9999 continue + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_get_neigh + +subroutine psb_base_allocate_mnnz(m,n,a,nz) + use psb_base_mat_mod, psb_protect_name => psb_base_allocate_mnnz + use psb_error_mod + implicit none + integer, intent(in) :: m,n + class(psb_base_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_allocate_mnnz + +subroutine psb_base_reallocate_nz(nz,a) + use psb_base_mat_mod, psb_protect_name => psb_base_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_base_sparse_mat), intent(inout) :: a + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_reallocate_nz + +subroutine psb_base_free(a) + use psb_base_mat_mod, psb_protect_name => psb_base_free + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(inout) :: a + Integer :: err_act + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_free + +subroutine psb_base_trim(a) + use psb_base_mat_mod, psb_protect_name => psb_base_trim + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(inout) :: a + Integer :: err_act + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(700,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_trim + diff --git a/base/serial/f03/psb_c_base_mat_impl.f03 b/base/serial/f03/psb_c_base_mat_impl.f03 new file mode 100644 index 00000000..57a01d08 --- /dev/null +++ b/base/serial/f03/psb_c_base_mat_impl.f03 @@ -0,0 +1,1078 @@ +!==================================== +! +! +! +! Data management +! +! +! +! +! +!==================================== + +subroutine psb_c_base_cp_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_to_coo + +subroutine psb_c_base_cp_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_from_coo + + +subroutine psb_c_base_cp_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_to_fmt + +subroutine psb_c_base_cp_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_from_fmt + + +subroutine psb_c_base_mv_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_to_coo + +subroutine psb_c_base_mv_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_from_coo + + +subroutine psb_c_base_mv_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_to_fmt + +subroutine psb_c_base_mv_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_from_fmt + +subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_csput + +subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csgetrow + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_csgetrow + + + +subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csgetblk + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_base_csgetblk + + +subroutine psb_c_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csclip + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_base_csclip + + +subroutine psb_c_base_transp_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_c_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='c_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_c_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + class default + info = 700 + end select + if (info /= 0) then + call psb_errpush(info,name,a_err=b%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_transp_2mat + +subroutine psb_c_base_transc_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transc_2mat + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transc(b) +end subroutine psb_c_base_transc_2mat + +subroutine psb_c_base_transp_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(inout) :: a + + type(psb_c_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='c_base_transp' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + + if (info /= 0) then + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_transp_1mat + +subroutine psb_c_base_transc_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transc_1mat + implicit none + + class(psb_c_base_sparse_mat), intent(inout) :: a + + call a%transc() +end subroutine psb_c_base_transc_1mat + + +!==================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!==================================== + +subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmm + use psb_error_mod + + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_csmm + + +subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmv + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_c_base_csmv + + +subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_cssm + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_inner_cssm + + +subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_cssv + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_inner_cssv + + +subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + + complex(psb_spk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='c_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(cone,x,czero,tmp,info,trans) + + if (info == 0)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == 0)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_c_base_cssm + + +subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + + complex(psb_spk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='c_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= 0) info = 4000 + if (info == 0) call inner_vscal(nac,d,x,tmp) + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == czero) then + call a%inner_cssm(alpha,x,czero,y,info,trans) + if (info == 0) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(alpha,x,czero,tmp,info,trans) + + if (info == 0) call inner_vscal1(nar,d,tmp) + if (info == 0)& + & call psb_geaxpby(nar,cone,tmp,beta,y,info) + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + complex(psb_spk_), intent(in) :: d(*),x(*) + complex(psb_spk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + complex(psb_spk_), intent(in) :: d(*) + complex(psb_spk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_c_base_cssv + + +subroutine psb_c_base_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scals + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='c_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_scals + + + +subroutine psb_c_base_scal(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scal + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='c_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_scal + + + +function psb_c_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csnmi + + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_c_base_csnmi + +subroutine psb_c_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_get_diag + + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_get_diag + + + + diff --git a/base/serial/f03/psb_c_coo_impl.f03 b/base/serial/f03/psb_c_coo_impl.f03 index 4592d48a..e32be6ad 100644 --- a/base/serial/f03/psb_c_coo_impl.f03 +++ b/base/serial/f03/psb_c_coo_impl.f03 @@ -1,9 +1,439 @@ -subroutine c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_get_diag(a,d,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = zzero + + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_get_diag + + +subroutine psb_c_coo_scal(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_scal + + +subroutine psb_c_coo_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scals + use psb_error_mod use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_scals + + +subroutine psb_c_coo_reallocate_nz(nz,a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_c_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_reallocate_nz + + + +subroutine psb_c_coo_reinit(a,clear) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reinit + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_reinit + + + +subroutine psb_c_coo_trim(a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + nz = a%get_nzeros() + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_trim + + +subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_allocate_mnnz use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_allocate_mnnz + + + +subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_print use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_cssm_impl + implicit none + + integer, intent(in) :: iout + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_c_coo_print + + + + +function psb_c_coo_get_nc_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_nc_row + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_c_coo_get_nc_row + +subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cssm implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -17,7 +447,7 @@ subroutine c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) complex(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra Integer :: err_act - character(len=20) :: name='c_base_cssm' + character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. info = 0 @@ -44,6 +474,17 @@ subroutine c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T') ctra = (psb_toupper(trans_)=='C') m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() @@ -340,15 +781,15 @@ contains end if end subroutine inner_coosm -end subroutine c_coo_cssm_impl +end subroutine psb_c_coo_cssm -subroutine c_coo_cssv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_cssv_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cssv implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -382,7 +823,16 @@ subroutine c_coo_cssv_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T') ctra = (psb_toupper(trans_)=='C') m = a%get_nrows() - + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if if (.not. (a%is_triangle())) then info = 1121 call psb_errpush(info,name) @@ -678,13 +1128,13 @@ contains end subroutine inner_coosv -end subroutine c_coo_cssv_impl +end subroutine psb_c_coo_cssv -subroutine c_coo_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_csMv_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csmv implicit none class(psb_c_coo_sparse_mat), intent(in) :: a @@ -729,6 +1179,16 @@ subroutine c_coo_csmv_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if nnz = a%get_nzeros() if (alpha == zzero) then @@ -865,14 +1325,14 @@ subroutine c_coo_csmv_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine c_coo_csmv_impl +end subroutine psb_c_coo_csmv -subroutine c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_csmm_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csmm implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -917,6 +1377,17 @@ subroutine c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() nc = min(size(x,2), size(y,2)) @@ -1061,11 +1532,11 @@ subroutine c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine c_coo_csmm_impl +end subroutine psb_c_coo_csmm -function c_coo_csnmi_impl(a) result(res) +function psb_c_coo_csnmi(a) result(res) use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_csnmi_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csnmi implicit none class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1094,7 +1565,7 @@ function c_coo_csnmi_impl(a) result(res) i = j end do -end function c_coo_csnmi_impl +end function psb_c_coo_csnmi @@ -1112,13 +1583,13 @@ end function c_coo_csnmi_impl -subroutine c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_csgetptn_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csgetptn implicit none class(psb_c_coo_sparse_mat), intent(in) :: a @@ -1183,7 +1654,7 @@ subroutine c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1383,16 +1854,16 @@ contains end subroutine coo_getptn -end subroutine c_coo_csgetptn_impl +end subroutine psb_c_coo_csgetptn -subroutine c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_csgetrow_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csgetrow implicit none class(psb_c_coo_sparse_mat), intent(in) :: a @@ -1458,7 +1929,7 @@ subroutine c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1667,16 +2138,16 @@ contains end subroutine coo_getrow -end subroutine c_coo_csgetrow_impl +end subroutine psb_c_coo_csgetrow -subroutine c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod use psb_sort_mod - use psb_c_base_mat_mod, psb_protect_name => c_coo_csput_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csput implicit none - + class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -1691,7 +2162,7 @@ subroutine c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 0 call psb_erractionsave(err_act) - + if (nz <= 0) then info = 10 int_err(1)=1 @@ -1734,7 +2205,7 @@ subroutine c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info,gtl) call a%set_nzeros(nza) call a%set_sorted(.false.) - + else if (a%is_upd()) then @@ -2044,18 +2515,176 @@ contains end if - end subroutine c_coo_srch_upd + end subroutine c_coo_srch_upd + +end subroutine psb_c_coo_csput + + +subroutine psb_c_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_coo + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + b%ia(:) = a%ia(:) + b%ja(:) = a%ja(:) + b%val(:) = a%val(:) + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_to_coo + +subroutine psb_c_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_coo + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_from_coo + + +subroutine psb_c_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_fmt + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_to_fmt + +subroutine psb_c_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_fmt + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return -end subroutine c_coo_csput_impl +end subroutine psb_c_cp_coo_from_fmt -subroutine c_cp_coo_to_coo_impl(a,b,info) +subroutine psb_c_mv_coo_to_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_to_coo_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_to_coo implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2065,14 +2694,14 @@ subroutine c_cp_coo_to_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) - + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) - b%ia(:) = a%ia(:) - b%ja(:) = a%ja(:) - b%val(:) = a%val(:) + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() call b%fix(info) @@ -2091,15 +2720,14 @@ subroutine c_cp_coo_to_coo_impl(a,b,info) end if return -end subroutine c_cp_coo_to_coo_impl - -subroutine c_cp_coo_from_coo_impl(a,b,info) +end subroutine psb_c_mv_coo_to_coo + +subroutine psb_c_mv_coo_from_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_from_coo_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_from_coo implicit none - class(psb_c_coo_sparse_mat), intent(out) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2110,14 +2738,14 @@ subroutine c_cp_coo_from_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) - a%ia(:) = b%ia(:) - a%ja(:) = b%ja(:) - a%val(:) = b%val(:) - + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() call a%fix(info) if (info /= 0) goto 9999 @@ -2135,16 +2763,15 @@ subroutine c_cp_coo_from_coo_impl(a,b,info) end if return -end subroutine c_cp_coo_from_coo_impl +end subroutine psb_c_mv_coo_from_coo -subroutine c_cp_coo_to_fmt_impl(a,b,info) +subroutine psb_c_mv_coo_to_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_to_fmt_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_to_fmt implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2155,7 +2782,7 @@ subroutine c_cp_coo_to_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_from_coo(a,info) + call b%mv_from_coo(a,info) if (info /= 0) goto 9999 @@ -2172,15 +2799,14 @@ subroutine c_cp_coo_to_fmt_impl(a,b,info) end if return -end subroutine c_cp_coo_to_fmt_impl - -subroutine c_cp_coo_from_fmt_impl(a,b,info) +end subroutine psb_c_mv_coo_to_fmt + +subroutine psb_c_mv_coo_from_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_from_fmt_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_from_fmt implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(in) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2192,8 +2818,74 @@ subroutine c_cp_coo_from_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_to_coo(a,info) + call b%mv_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_mv_coo_from_fmt + +subroutine psb_c_coo_cp_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cp_from + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + type(psb_c_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%cp_from_coo(b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_coo_cp_from + +subroutine psb_c_coo_mv_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mv_from + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%mv_from_coo(b,info) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -2209,16 +2901,14 @@ subroutine c_cp_coo_from_fmt_impl(a,b,info) end if return -end subroutine c_cp_coo_from_fmt_impl +end subroutine psb_c_coo_mv_from + -subroutine c_fix_coo_impl(a,info,idir) +subroutine psb_c_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_string_mod - use psb_ip_reord_mod - use psb_c_base_mat_mod, psb_protect_name => c_fix_coo_impl + use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a @@ -2251,12 +2941,12 @@ subroutine c_fix_coo_impl(a,info,idir) dupl_ = a%get_dupl() - call c_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - + call psb_c_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= 0) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() - + call psb_erractionrestore(err_act) return @@ -2269,19 +2959,18 @@ subroutine c_fix_coo_impl(a,info,idir) end if return -end subroutine c_fix_coo_impl +end subroutine psb_c_fix_coo -subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_fix_coo_inner + use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo_inner use psb_string_mod use psb_ip_reord_mod implicit none - + integer, intent(in) :: nzin, dupl integer, intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) @@ -2313,7 +3002,7 @@ subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (nzin < 2) return dupl_ = dupl - + allocate(iaux(nzin+2),stat=info) if (info /= 0) return @@ -2490,7 +3179,7 @@ subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) end select nzout = i - + deallocate(iaux) call psb_erractionrestore(err_act) @@ -2506,169 +3195,5 @@ subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) -end subroutine c_fix_coo_inner - - - - -subroutine c_mv_coo_to_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_to_coo_impl - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) - call b%set_nzeros(a%get_nzeros()) - call b%reallocate(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call a%free() - - call b%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine c_mv_coo_to_coo_impl - -subroutine c_mv_coo_from_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_from_coo_impl - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) - call a%set_nzeros(b%get_nzeros()) - call a%reallocate(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine c_mv_coo_from_coo_impl - - -subroutine c_mv_coo_to_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_to_fmt_impl - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_from_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine c_mv_coo_to_fmt_impl - -subroutine c_mv_coo_from_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_from_fmt_impl - implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_to_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return +end subroutine psb_c_fix_coo_inner -end subroutine c_mv_coo_from_fmt_impl diff --git a/base/serial/f03/psb_c_csc_impl.f03 b/base/serial/f03/psb_c_csc_impl.f03 index baa115a8..d7a60aed 100644 --- a/base/serial/f03/psb_c_csc_impl.f03 +++ b/base/serial/f03/psb_c_csc_impl.f03 @@ -1,4 +1,3 @@ - !===================================== ! ! @@ -12,10 +11,10 @@ ! !===================================== -subroutine c_csc_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_c_csc_mat_mod, psb_protect_name => c_csc_csmv_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csmv implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -60,6 +59,19 @@ subroutine c_csc_csmv_impl(alpha,a,x,beta,y,info,trans) end if + if (size(x,1) c_csc_csmm_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csmm implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -460,6 +472,19 @@ subroutine c_csc_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) c_csc_cssv_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cssv implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -869,6 +894,19 @@ subroutine c_csc_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x,1) c_csc_cssm_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cssm implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -1114,6 +1156,19 @@ subroutine c_csc_cssm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() nc = min(size(x,2) , size(y,2)) + if (size(x,1) c_csc_csnmi_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csnmi implicit none class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1348,14 +1403,14 @@ function c_csc_csnmi_impl(a) result(res) logical, parameter :: debug=.false. - res = szero + res = czero nr = a%get_nrows() nc = a%get_ncols() allocate(acc(nr),stat=info) if (info /= 0) then return end if - acc(:) = szero + acc(:) = dzero do i=1, nc do j=a%icp(i),a%icp(i+1)-1 acc(a%ia(j)) = acc(a%ia(j)) + abs(a%val(j)) @@ -1366,7 +1421,135 @@ function c_csc_csnmi_impl(a) result(res) end do deallocate(acc) -end function c_csc_csnmi_impl +end function psb_c_csc_csnmi + + +subroutine psb_c_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_get_diag + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = czero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_get_diag + + +subroutine psb_c_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scal + implicit none + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_scal + + +subroutine psb_c_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scals + implicit none + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_scals + !===================================== ! @@ -1380,14 +1563,14 @@ end function c_csc_csnmi_impl ! !===================================== -subroutine c_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_csc_csgetptn_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetptn implicit none class(psb_c_csc_sparse_mat), intent(in) :: a @@ -1563,19 +1746,19 @@ contains end subroutine csc_getptn -end subroutine c_csc_csgetptn_impl +end subroutine psb_c_csc_csgetptn -subroutine c_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_csc_csgetrow_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetrow implicit none class(psb_c_csc_sparse_mat), intent(in) :: a @@ -1758,14 +1941,14 @@ contains end if end subroutine csc_getrow -end subroutine c_csc_csgetrow_impl +end subroutine psb_c_csc_csgetrow -subroutine c_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_c_csc_mat_mod, psb_protect_name => c_csc_csput_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -1780,7 +1963,37 @@ subroutine c_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1788,9 +2001,9 @@ subroutine c_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call c_csc_srch_upd(nz,ia,ja,val,a,& + call psb_c_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1820,7 +2033,7 @@ subroutine c_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine c_csc_srch_upd(nz,ia,ja,val,a,& + subroutine psb_c_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -2018,17 +2231,17 @@ contains end if - end subroutine c_csc_srch_upd + end subroutine psb_c_csc_srch_upd -end subroutine c_csc_csput_impl +end subroutine psb_c_csc_csput -subroutine c_cp_csc_from_coo_impl(a,b,info) +subroutine psb_c_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_cp_csc_from_coo_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_from_coo implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -2049,18 +2262,18 @@ subroutine c_cp_csc_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine c_cp_csc_from_coo_impl +end subroutine psb_c_cp_csc_from_coo -subroutine c_cp_csc_to_coo_impl(a,b,info) +subroutine psb_c_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_cp_csc_to_coo_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_to_coo implicit none class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -2092,18 +2305,18 @@ subroutine c_cp_csc_to_coo_impl(a,b,info) call b%fix(info) -end subroutine c_cp_csc_to_coo_impl +end subroutine psb_c_cp_csc_to_coo -subroutine c_mv_csc_to_coo_impl(a,b,info) +subroutine psb_c_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_mv_csc_to_coo_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_to_coo implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -2134,15 +2347,15 @@ subroutine c_mv_csc_to_coo_impl(a,b,info) call a%free() call b%fix(info) -end subroutine c_mv_csc_to_coo_impl +end subroutine psb_c_mv_csc_to_coo -subroutine c_mv_csc_from_coo_impl(a,b,info) +subroutine psb_c_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_mv_csc_from_coo_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_coo implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -2225,18 +2438,18 @@ subroutine c_mv_csc_from_coo_impl(a,b,info) endif -end subroutine c_mv_csc_from_coo_impl +end subroutine psb_c_mv_csc_from_coo -subroutine c_mv_csc_to_fmt_impl(a,b,info) +subroutine psb_c_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_mv_csc_to_fmt_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_to_fmt implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2265,18 +2478,18 @@ subroutine c_mv_csc_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine c_mv_csc_to_fmt_impl +end subroutine psb_c_mv_csc_to_fmt !!$ -subroutine c_cp_csc_to_fmt_impl(a,b,info) +subroutine psb_c_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_cp_csc_to_fmt_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_to_fmt implicit none class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2305,14 +2518,14 @@ subroutine c_cp_csc_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine c_cp_csc_to_fmt_impl +end subroutine psb_c_cp_csc_to_fmt -subroutine c_mv_csc_from_fmt_impl(a,b,info) +subroutine psb_c_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_mv_csc_from_fmt_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_fmt implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -2345,15 +2558,15 @@ subroutine c_mv_csc_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine c_mv_csc_from_fmt_impl +end subroutine psb_c_mv_csc_from_fmt -subroutine c_cp_csc_from_fmt_impl(a,b,info) +subroutine psb_c_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csc_mat_mod, psb_protect_name => c_cp_csc_from_fmt_impl + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_from_fmt implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -2384,5 +2597,403 @@ subroutine c_cp_csc_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine c_cp_csc_from_fmt_impl +end subroutine psb_c_cp_csc_from_fmt + + +subroutine psb_c_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_c_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_reallocate_nz + + + +subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetblk + implicit none + + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_csgetblk + +subroutine psb_c_csc_reinit(a,clear) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_reinit + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_reinit + +subroutine psb_c_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_trim + implicit none + class(psb_c_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + n = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_trim + +subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_c_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_allocate_mnnz + +subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_c_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_c_csc_print + +subroutine psb_c_csc_cp_from(a,b) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cp_from + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + type(psb_c_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csc_cp_from + +subroutine psb_c_csc_mv_from(a,b) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mv_from + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csc_mv_from + + diff --git a/base/serial/f03/psb_c_csr_impl.f03 b/base/serial/f03/psb_c_csr_impl.f03 index 0b25ad0c..a4460a18 100644 --- a/base/serial/f03/psb_c_csr_impl.f03 +++ b/base/serial/f03/psb_c_csr_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine c_csr_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_c_csr_mat_mod, psb_protect_name => c_csr_csmv_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csmv implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -50,7 +50,7 @@ subroutine c_csr_csmv_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T') ctra = (psb_toupper(trans_)=='C') - if (tra.or.ctra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -58,7 +58,20 @@ subroutine c_csr_csmv_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - call c_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + if (size(x,1) c_csr_csmm_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csmm implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -389,6 +402,18 @@ subroutine c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) c_csr_cssv_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cssv implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -725,6 +750,17 @@ subroutine c_csr_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x) c_csr_cssm_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cssm implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -953,7 +989,7 @@ subroutine c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) complex(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra Integer :: err_act - character(len=20) :: name='c_base_cssm' + character(len=20) :: name='c_csr_cssm' logical, parameter :: debug=.false. info = 0 @@ -1198,11 +1234,11 @@ contains end if end subroutine inner_csrsm -end subroutine c_csr_cssm_impl +end subroutine psb_c_csr_cssm -function c_csr_csnmi_impl(a) result(res) +function psb_c_csr_csnmi(a) result(res) use psb_error_mod - use psb_c_csr_mat_mod, psb_protect_name => c_csr_csnmi_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csnmi implicit none class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1225,7 +1261,136 @@ function c_csr_csnmi_impl(a) result(res) res = max(res,acc) end do -end function c_csr_csnmi_impl +end function psb_c_csr_csnmi + +subroutine psb_c_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_get_diag + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_get_diag + + +subroutine psb_c_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scal + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_scal + + +subroutine psb_c_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scals + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_scals + + + !===================================== ! @@ -1240,14 +1405,113 @@ end function c_csr_csnmi_impl !===================================== -subroutine c_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_c_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_c_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_reallocate_nz + + +subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_c_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_allocate_mnnz + + +subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_csr_csgetptn_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csgetptn implicit none class(psb_c_csr_sparse_mat), intent(in) :: a @@ -1358,7 +1622,7 @@ contains integer, optional :: iren(:) integer :: nzin_, nza, idx,i,j,k, nzt, irw, lrw integer :: debug_level, debug_unit - character(len=20) :: name='coo_getrow' + character(len=20) :: name='csr_getptn' debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -1412,17 +1676,17 @@ contains end subroutine csr_getptn -end subroutine c_csr_csgetptn_impl +end subroutine psb_c_csr_csgetptn -subroutine c_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_csr_csgetrow_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csgetrow implicit none class(psb_c_csr_sparse_mat), intent(in) :: a @@ -1443,7 +1707,7 @@ subroutine c_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& call psb_erractionsave(err_act) info = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1593,14 +1857,73 @@ contains end subroutine csr_getrow -end subroutine c_csr_csgetrow_impl +end subroutine psb_c_csr_csgetrow + +subroutine psb_c_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csgetblk + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_csgetblk -subroutine c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_c_csr_mat_mod, psb_protect_name => c_csr_csput_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -1615,7 +1938,38 @@ subroutine c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1623,9 +1977,9 @@ subroutine c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call c_csr_srch_upd(nz,ia,ja,val,a,& + call psb_c_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1655,7 +2009,7 @@ subroutine c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine c_csr_srch_upd(nz,ia,ja,val,a,& + subroutine psb_c_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -1848,17 +2202,181 @@ contains end if - end subroutine c_csr_srch_upd + end subroutine psb_c_csr_srch_upd + +end subroutine psb_c_csr_csput + + +subroutine psb_c_csr_reinit(a,clear) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_reinit + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear -end subroutine c_csr_csput_impl + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_reinit + +subroutine psb_c_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_trim + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + m = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(m+1,a%irp,info) + + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_c_csr_trim -subroutine c_cp_csr_from_coo_impl(a,b,info) +subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_c_csr_print + + +subroutine psb_c_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_from_coo_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_coo implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -1871,7 +2389,7 @@ subroutine c_cp_csr_from_coo_impl(a,b,info) logical :: rwshr_ Integer :: nza, nr, i,j,irw, idl,err_act, nc Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit + integer :: debug_level, debug_unit character(len=20) :: name info = 0 @@ -1879,18 +2397,18 @@ subroutine c_cp_csr_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine c_cp_csr_from_coo_impl +end subroutine psb_c_cp_csr_from_coo -subroutine c_cp_csr_to_coo_impl(a,b,info) +subroutine psb_c_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_to_coo_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_to_coo implicit none class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1921,18 +2439,18 @@ subroutine c_cp_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine c_cp_csr_to_coo_impl +end subroutine psb_c_cp_csr_to_coo -subroutine c_mv_csr_to_coo_impl(a,b,info) +subroutine psb_c_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_to_coo_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_to_coo implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(out) :: b + class(psb_c_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1964,15 +2482,15 @@ subroutine c_mv_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine c_mv_csr_to_coo_impl +end subroutine psb_c_mv_csr_to_coo -subroutine c_mv_csr_from_coo_impl(a,b,info) +subroutine psb_c_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_from_coo_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_coo implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -2055,18 +2573,17 @@ subroutine c_mv_csr_from_coo_impl(a,b,info) endif -end subroutine c_mv_csr_from_coo_impl +end subroutine psb_c_mv_csr_from_coo -subroutine c_mv_csr_to_fmt_impl(a,b,info) +subroutine psb_c_mv_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_to_fmt_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_to_fmt implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2095,18 +2612,17 @@ subroutine c_mv_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine c_mv_csr_to_fmt_impl +end subroutine psb_c_mv_csr_to_fmt -subroutine c_cp_csr_to_fmt_impl(a,b,info) +subroutine psb_c_cp_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_to_fmt_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_to_fmt implicit none class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b + class(psb_c_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2135,14 +2651,13 @@ subroutine c_cp_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine c_cp_csr_to_fmt_impl +end subroutine psb_c_cp_csr_to_fmt -subroutine c_mv_csr_from_fmt_impl(a,b,info) +subroutine psb_c_mv_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_from_fmt_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_fmt implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -2175,15 +2690,14 @@ subroutine c_mv_csr_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine c_mv_csr_from_fmt_impl +end subroutine psb_c_mv_csr_from_fmt -subroutine c_cp_csr_from_fmt_impl(a,b,info) +subroutine psb_c_cp_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_from_fmt_impl + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_fmt implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -2214,5 +2728,82 @@ subroutine c_cp_csr_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine c_cp_csr_from_fmt_impl +end subroutine psb_c_cp_csr_from_fmt + + +subroutine psb_c_csr_cp_from(a,b) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cp_from + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + type(psb_c_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csr_cp_from + +subroutine psb_c_csr_mv_from(a,b) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mv_from + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + type(psb_c_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csr_mv_from + diff --git a/base/serial/f03/psb_c_mat_impl.f03 b/base/serial/f03/psb_c_mat_impl.f03 new file mode 100644 index 00000000..f7bfeb3e --- /dev/null +++ b/base/serial/f03/psb_c_mat_impl.f03 @@ -0,0 +1,1990 @@ +!===================================== +! +! +! +! Setters +! +! +! +! +! +! +!===================================== + + +subroutine psb_c_set_nrows(m,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_nrows + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_nrows + + +subroutine psb_c_set_ncols(n,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_ncols + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_ncols + + + +subroutine psb_c_set_state(n,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_state + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_state + + + +subroutine psb_c_set_dupl(n,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_dupl + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_dupl + + +subroutine psb_c_set_null(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_null + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_null + + +subroutine psb_c_set_bld(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_bld + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_bld + + +subroutine psb_c_set_upd(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_upd + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +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 + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_asb + + +subroutine psb_c_set_sorted(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_sorted + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_sorted + + +subroutine psb_c_set_triangle(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_triangle + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_triangle + + +subroutine psb_c_set_unit(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_unit + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_lower + + +subroutine psb_c_set_upper(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_upper + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_upper + + + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine psb_c_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_c_mat_mod, psb_protect_name => psb_c_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 0 + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_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 + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_get_neigh + + + +subroutine psb_c_csall(nr,nc,a,info,nz) + use psb_c_mat_mod, psb_protect_name => psb_c_csall + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + allocate(psb_c_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csall + + +subroutine psb_c_reallocate_nz(nz,a) + use psb_c_mat_mod, psb_protect_name => psb_c_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_reallocate_nz + + +subroutine psb_c_free(a) + use psb_c_mat_mod, psb_protect_name => psb_c_free + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%free() + deallocate(a%a) + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_free + + +subroutine psb_c_trim(a) + use psb_c_mat_mod, psb_protect_name => psb_c_trim + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_trim + + + +subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_mat_mod, psb_protect_name => psb_c_csput + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csput + + +subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csgetptn + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csgetptn + + +subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csgetrow + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csgetblk + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + + if (info == 0) call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csgetblk + + + + +subroutine psb_c_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csclip + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csclip + + +subroutine psb_c_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_b_csclip + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_b_csclip + + + + +subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cscnv + implicit none + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + + class(psb_c_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_cscnv + + + +subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_ip + implicit none + + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + + class(psb_c_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + 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 = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_cscnv_ip + + + +subroutine psb_c_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_base + implicit none + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_c_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == 0).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == 0) call altmp%trim() + if (info == 0) call altmp%set_asb() + if (info == 0) call b%mv_from_coo(altmp,info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_cscnv_base + + + +subroutine psb_c_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_clip_d + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%cp_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_clip_d + + + +subroutine psb_c_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_clip_d_ip + implicit none + + class(psb_c_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%mv_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_clip_d_ip + + +subroutine psb_c_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_from + implicit none + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer :: info + + allocate(a%a,source=b, stat=info) + call a%a%mv_from_fmt(b,info) + + return +end subroutine psb_c_mv_from + + +subroutine psb_c_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_from + implicit none + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(a%a,source=b,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call a%a%cp_from_fmt(b, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_c_cp_from + + +subroutine psb_c_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_to + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_c_mv_to + + +subroutine psb_c_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_to + implicit none + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_c_cp_to + + + +subroutine psb_c_sparse_mat_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_sparse_mat_move + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = 0 + call move_alloc(a%a,b%a) + + return +end subroutine psb_c_sparse_mat_move + + +subroutine psb_c_sparse_mat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_sparse_mat_clone + implicit none + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(b%a,source=a%a,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call b%a%cp_from_fmt(a%a, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_sparse_mat_clone + + + +subroutine psb_c_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transp_1mat + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transp_1mat + + + +subroutine psb_c_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transp_2mat + implicit none + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transp_2mat + + +subroutine psb_c_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transc_1mat + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transc_1mat + + + +subroutine psb_c_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transc_2mat + implicit none + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transc_2mat + + + + +subroutine psb_c_reinit(a,clear) + use psb_c_mat_mod, psb_protect_name => psb_c_reinit + use psb_error_mod + implicit none + + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_reinit + + + + +!===================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!===================================== + + +subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csmm + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csmm + + +subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csmv + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csmv + + +subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cssm + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_cssm + + +subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cssv + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_cssv + + + +function psb_c_csnmi(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_c_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_c_csnmi + + +subroutine psb_c_get_diag(a,d,info) + use psb_c_mat_mod, psb_protect_name => psb_c_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_get_diag + + +subroutine psb_c_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_scal + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_scal + + +subroutine psb_c_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_scals + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_scals + + + diff --git a/base/serial/f03/psb_d_base_mat_impl.f03 b/base/serial/f03/psb_d_base_mat_impl.f03 new file mode 100644 index 00000000..e4de9c65 --- /dev/null +++ b/base/serial/f03/psb_d_base_mat_impl.f03 @@ -0,0 +1,1078 @@ +!==================================== +! +! +! +! Data management +! +! +! +! +! +!==================================== + +subroutine psb_d_base_cp_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_to_coo + +subroutine psb_d_base_cp_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_from_coo + + +subroutine psb_d_base_cp_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_to_fmt + +subroutine psb_d_base_cp_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_from_fmt + + +subroutine psb_d_base_mv_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_to_coo + +subroutine psb_d_base_mv_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_from_coo + + +subroutine psb_d_base_mv_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_to_fmt + +subroutine psb_d_base_mv_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_from_fmt + +subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_csput + +subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csgetrow + implicit none + + class(psb_d_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_csgetrow + + + +subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csgetblk + implicit none + + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_base_csgetblk + + +subroutine psb_d_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csclip + implicit none + + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_base_csclip + + +subroutine psb_d_base_transp_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_d_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='d_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_d_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + class default + info = 700 + end select + if (info /= 0) then + call psb_errpush(info,name,a_err=b%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_transp_2mat + +subroutine psb_d_base_transc_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transc_2mat + implicit none + + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) +end subroutine psb_d_base_transc_2mat + +subroutine psb_d_base_transp_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(inout) :: a + + type(psb_d_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='d_base_transp' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + + if (info /= 0) then + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_transp_1mat + +subroutine psb_d_base_transc_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transc_1mat + implicit none + + class(psb_d_base_sparse_mat), intent(inout) :: a + + call a%transp() +end subroutine psb_d_base_transc_1mat + + +!==================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!==================================== + +subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmm + use psb_error_mod + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_csmm + + +subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmv + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_d_base_csmv + + +subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_cssm + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_inner_cssm + + +subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_cssv + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_inner_cssv + + +subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + + real(psb_dpk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='d_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(done,x,dzero,tmp,info,trans) + + if (info == 0)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == 0)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_d_base_cssm + + +subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + + real(psb_dpk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='d_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= 0) info = 4000 + if (info == 0) call inner_vscal(nac,d,x,tmp) + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == dzero) then + call a%inner_cssm(alpha,x,dzero,y,info,trans) + if (info == 0) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(alpha,x,dzero,tmp,info,trans) + + if (info == 0) call inner_vscal1(nar,d,tmp) + if (info == 0)& + & call psb_geaxpby(nar,done,tmp,beta,y,info) + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + real(psb_dpk_), intent(in) :: d(*),x(*) + real(psb_dpk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + real(psb_dpk_), intent(in) :: d(*) + real(psb_dpk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_d_base_cssv + + +subroutine psb_d_base_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scals + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='d_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_scals + + + +subroutine psb_d_base_scal(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scal + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='d_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_scal + + + +function psb_d_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csnmi + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_d_base_csnmi + +subroutine psb_d_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_get_diag + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_get_diag + + + + diff --git a/base/serial/f03/psb_d_coo_impl.f03 b/base/serial/f03/psb_d_coo_impl.f03 index bd3e9e4a..a1ee0477 100644 --- a/base/serial/f03/psb_d_coo_impl.f03 +++ b/base/serial/f03/psb_d_coo_impl.f03 @@ -1,10 +1,439 @@ -subroutine d_coo_cssm_impl(alpha,a,x,beta,y,info,trans) -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ use psb_string_mod -!!$ use psb_d_base_mat_mod, psb_protect_name => d_coo_cssm_impl - use psb_sparse_mod, psb_protect_name => d_coo_cssm_impl +subroutine psb_d_coo_get_diag(a,d,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = dzero + + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_get_diag + + +subroutine psb_d_coo_scal(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_scal + + +subroutine psb_d_coo_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_scals + + +subroutine psb_d_coo_reallocate_nz(nz,a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_d_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_reallocate_nz + + + +subroutine psb_d_coo_reinit(a,clear) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reinit + use psb_error_mod + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_reinit + + + +subroutine psb_d_coo_trim(a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + nz = a%get_nzeros() + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_trim + + +subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_d_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_allocate_mnnz + + + +subroutine psb_d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_print + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_d_coo_print + + + + +function psb_d_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_nz_row + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_d_coo_get_nz_row + +subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cssm implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -44,6 +473,17 @@ subroutine d_coo_cssm_impl(alpha,a,x,beta,y,info,trans) end if tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() @@ -271,15 +711,15 @@ contains end if end subroutine inner_coosm -end subroutine d_coo_cssm_impl +end subroutine psb_d_coo_cssm -subroutine d_coo_cssv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_cssv_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cssv implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -312,7 +752,16 @@ subroutine d_coo_cssv_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if if (.not. (a%is_triangle())) then info = 1121 call psb_errpush(info,name) @@ -539,13 +988,13 @@ contains end subroutine inner_coosv -end subroutine d_coo_cssv_impl +end subroutine psb_d_coo_cssv -subroutine d_coo_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_csMv_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csmv implicit none class(psb_d_coo_sparse_mat), intent(in) :: a @@ -588,6 +1037,16 @@ subroutine d_coo_csmv_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if nnz = a%get_nzeros() if (alpha == dzero) then @@ -696,14 +1155,14 @@ subroutine d_coo_csmv_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine d_coo_csmv_impl +end subroutine psb_d_coo_csmv -subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_csmm_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csmm implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -746,6 +1205,17 @@ subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() nc = min(size(x,2), size(y,2)) @@ -862,11 +1332,11 @@ subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine d_coo_csmm_impl +end subroutine psb_d_coo_csmm -function d_coo_csnmi_impl(a) result(res) +function psb_d_coo_csnmi(a) result(res) use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_csnmi_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csnmi implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -895,7 +1365,7 @@ function d_coo_csnmi_impl(a) result(res) i = j end do -end function d_coo_csnmi_impl +end function psb_d_coo_csnmi @@ -913,13 +1383,13 @@ end function d_coo_csnmi_impl -subroutine d_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_csgetptn_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csgetptn implicit none class(psb_d_coo_sparse_mat), intent(in) :: a @@ -984,7 +1454,7 @@ subroutine d_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1184,16 +1654,16 @@ contains end subroutine coo_getptn -end subroutine d_coo_csgetptn_impl +end subroutine psb_d_coo_csgetptn -subroutine d_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_csgetrow_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csgetrow implicit none class(psb_d_coo_sparse_mat), intent(in) :: a @@ -1259,7 +1729,7 @@ subroutine d_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1468,16 +1938,16 @@ contains end subroutine coo_getrow -end subroutine d_coo_csgetrow_impl +end subroutine psb_d_coo_csgetrow -subroutine d_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod use psb_sort_mod - use psb_d_base_mat_mod, psb_protect_name => d_coo_csput_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput implicit none - + class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -1492,7 +1962,7 @@ subroutine d_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 0 call psb_erractionsave(err_act) - + if (nz <= 0) then info = 10 int_err(1)=1 @@ -1535,7 +2005,7 @@ subroutine d_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info,gtl) call a%set_nzeros(nza) call a%set_sorted(.false.) - + else if (a%is_upd()) then @@ -1845,18 +2315,176 @@ contains end if - end subroutine d_coo_srch_upd + end subroutine d_coo_srch_upd + +end subroutine psb_d_coo_csput + + +subroutine psb_d_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_coo + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + b%ia(:) = a%ia(:) + b%ja(:) = a%ja(:) + b%val(:) = a%val(:) + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_to_coo + +subroutine psb_d_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_coo + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_from_coo + + +subroutine psb_d_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_fmt + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_to_fmt + +subroutine psb_d_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_fmt + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return -end subroutine d_coo_csput_impl +end subroutine psb_d_cp_coo_from_fmt -subroutine d_cp_coo_to_coo_impl(a,b,info) +subroutine psb_d_mv_coo_to_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_cp_coo_to_coo_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_to_coo implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1866,14 +2494,14 @@ subroutine d_cp_coo_to_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) - + call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) - b%ia(:) = a%ia(:) - b%ja(:) = a%ja(:) - b%val(:) = a%val(:) + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() call b%fix(info) @@ -1892,15 +2520,14 @@ subroutine d_cp_coo_to_coo_impl(a,b,info) end if return -end subroutine d_cp_coo_to_coo_impl - -subroutine d_cp_coo_from_coo_impl(a,b,info) +end subroutine psb_d_mv_coo_to_coo + +subroutine psb_d_mv_coo_from_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_cp_coo_from_coo_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_from_coo implicit none - class(psb_d_coo_sparse_mat), intent(out) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1911,14 +2538,14 @@ subroutine d_cp_coo_from_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) - a%ia(:) = b%ia(:) - a%ja(:) = b%ja(:) - a%val(:) = b%val(:) - + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() call a%fix(info) if (info /= 0) goto 9999 @@ -1936,16 +2563,15 @@ subroutine d_cp_coo_from_coo_impl(a,b,info) end if return -end subroutine d_cp_coo_from_coo_impl +end subroutine psb_d_mv_coo_from_coo -subroutine d_cp_coo_to_fmt_impl(a,b,info) +subroutine psb_d_mv_coo_to_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_cp_coo_to_fmt_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_to_fmt implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1956,7 +2582,7 @@ subroutine d_cp_coo_to_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_from_coo(a,info) + call b%mv_from_coo(a,info) if (info /= 0) goto 9999 @@ -1973,15 +2599,14 @@ subroutine d_cp_coo_to_fmt_impl(a,b,info) end if return -end subroutine d_cp_coo_to_fmt_impl - -subroutine d_cp_coo_from_fmt_impl(a,b,info) +end subroutine psb_d_mv_coo_to_fmt + +subroutine psb_d_mv_coo_from_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_cp_coo_from_fmt_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_from_fmt implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(in) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1993,8 +2618,74 @@ subroutine d_cp_coo_from_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_to_coo(a,info) + call b%mv_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_mv_coo_from_fmt + +subroutine psb_d_coo_cp_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cp_from + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + type(psb_d_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%cp_from_coo(b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_coo_cp_from + +subroutine psb_d_coo_mv_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mv_from + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%mv_from_coo(b,info) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -2010,16 +2701,14 @@ subroutine d_cp_coo_from_fmt_impl(a,b,info) end if return -end subroutine d_cp_coo_from_fmt_impl +end subroutine psb_d_coo_mv_from + -subroutine d_fix_coo_impl(a,info,idir) +subroutine psb_d_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_string_mod - use psb_ip_reord_mod - use psb_d_base_mat_mod, psb_protect_name => d_fix_coo_impl + use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a @@ -2052,12 +2741,12 @@ subroutine d_fix_coo_impl(a,info,idir) dupl_ = a%get_dupl() - call d_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - + call psb_d_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= 0) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() - + call psb_erractionrestore(err_act) return @@ -2070,19 +2759,18 @@ subroutine d_fix_coo_impl(a,info,idir) end if return -end subroutine d_fix_coo_impl +end subroutine psb_d_fix_coo -subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_fix_coo_inner + use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo_inner use psb_string_mod use psb_ip_reord_mod implicit none - + integer, intent(in) :: nzin, dupl integer, intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) @@ -2114,7 +2802,7 @@ subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (nzin < 2) return dupl_ = dupl - + allocate(iaux(nzin+2),stat=info) if (info /= 0) return @@ -2291,7 +2979,7 @@ subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) end select nzout = i - + deallocate(iaux) call psb_erractionrestore(err_act) @@ -2307,169 +2995,5 @@ subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) -end subroutine d_fix_coo_inner - - - - -subroutine d_mv_coo_to_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_mv_coo_to_coo_impl - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) - call b%set_nzeros(a%get_nzeros()) - call b%reallocate(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call a%free() - - call b%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine d_mv_coo_to_coo_impl - -subroutine d_mv_coo_from_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_mv_coo_from_coo_impl - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) - call a%set_nzeros(b%get_nzeros()) - call a%reallocate(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine d_mv_coo_from_coo_impl - - -subroutine d_mv_coo_to_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_mv_coo_to_fmt_impl - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_from_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine d_mv_coo_to_fmt_impl - -subroutine d_mv_coo_from_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_d_base_mat_mod, psb_protect_name => d_mv_coo_from_fmt_impl - implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_to_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return +end subroutine psb_d_fix_coo_inner -end subroutine d_mv_coo_from_fmt_impl diff --git a/base/serial/f03/psb_d_csc_impl.f03 b/base/serial/f03/psb_d_csc_impl.f03 index 8bd90158..4c26df2d 100644 --- a/base/serial/f03/psb_d_csc_impl.f03 +++ b/base/serial/f03/psb_d_csc_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmv_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csmv implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -58,6 +58,19 @@ subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans) end if + if (size(x,1) d_csc_csmm_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csmm implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -319,6 +332,19 @@ subroutine d_csc_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) d_csc_cssv_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cssv implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -589,6 +615,19 @@ subroutine d_csc_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x,1) d_csc_cssm_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cssm implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -788,6 +830,19 @@ subroutine d_csc_cssm_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() + + if (size(x,1) d_csc_csnmi_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csnmi implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1000,7 +1058,135 @@ function d_csc_csnmi_impl(a) result(res) end do deallocate(acc) -end function d_csc_csnmi_impl +end function psb_d_csc_csnmi + + +subroutine psb_d_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_get_diag + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_get_diag + + +subroutine psb_d_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scal + implicit none + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_scal + + +subroutine psb_d_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scals + implicit none + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_scals + !===================================== ! @@ -1014,14 +1200,14 @@ end function d_csc_csnmi_impl ! !===================================== -subroutine d_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_csc_csgetptn_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetptn implicit none class(psb_d_csc_sparse_mat), intent(in) :: a @@ -1197,19 +1383,19 @@ contains end subroutine csc_getptn -end subroutine d_csc_csgetptn_impl +end subroutine psb_d_csc_csgetptn -subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_csc_csgetrow_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetrow implicit none class(psb_d_csc_sparse_mat), intent(in) :: a @@ -1392,14 +1578,14 @@ contains end if end subroutine csc_getrow -end subroutine d_csc_csgetrow_impl +end subroutine psb_d_csc_csgetrow -subroutine d_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_d_csc_mat_mod, psb_protect_name => d_csc_csput_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -1414,7 +1600,37 @@ subroutine d_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1422,9 +1638,9 @@ subroutine d_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call d_csc_srch_upd(nz,ia,ja,val,a,& + call psb_d_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1454,7 +1670,7 @@ subroutine d_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine d_csc_srch_upd(nz,ia,ja,val,a,& + subroutine psb_d_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -1652,17 +1868,17 @@ contains end if - end subroutine d_csc_srch_upd + end subroutine psb_d_csc_srch_upd -end subroutine d_csc_csput_impl +end subroutine psb_d_csc_csput -subroutine d_cp_csc_from_coo_impl(a,b,info) +subroutine psb_d_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_cp_csc_from_coo_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_from_coo implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -1683,18 +1899,18 @@ subroutine d_cp_csc_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine d_cp_csc_from_coo_impl +end subroutine psb_d_cp_csc_from_coo -subroutine d_cp_csc_to_coo_impl(a,b,info) +subroutine psb_d_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_cp_csc_to_coo_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_to_coo implicit none class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1726,18 +1942,18 @@ subroutine d_cp_csc_to_coo_impl(a,b,info) call b%fix(info) -end subroutine d_cp_csc_to_coo_impl +end subroutine psb_d_cp_csc_to_coo -subroutine d_mv_csc_to_coo_impl(a,b,info) +subroutine psb_d_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_mv_csc_to_coo_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_to_coo implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1768,15 +1984,15 @@ subroutine d_mv_csc_to_coo_impl(a,b,info) call a%free() call b%fix(info) -end subroutine d_mv_csc_to_coo_impl +end subroutine psb_d_mv_csc_to_coo -subroutine d_mv_csc_from_coo_impl(a,b,info) +subroutine psb_d_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_mv_csc_from_coo_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_coo implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -1859,18 +2075,18 @@ subroutine d_mv_csc_from_coo_impl(a,b,info) endif -end subroutine d_mv_csc_from_coo_impl +end subroutine psb_d_mv_csc_from_coo -subroutine d_mv_csc_to_fmt_impl(a,b,info) +subroutine psb_d_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_mv_csc_to_fmt_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_to_fmt implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1899,18 +2115,18 @@ subroutine d_mv_csc_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine d_mv_csc_to_fmt_impl +end subroutine psb_d_mv_csc_to_fmt !!$ -subroutine d_cp_csc_to_fmt_impl(a,b,info) +subroutine psb_d_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_cp_csc_to_fmt_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_to_fmt implicit none class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1939,14 +2155,14 @@ subroutine d_cp_csc_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine d_cp_csc_to_fmt_impl +end subroutine psb_d_cp_csc_to_fmt -subroutine d_mv_csc_from_fmt_impl(a,b,info) +subroutine psb_d_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_mv_csc_from_fmt_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_fmt implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -1979,15 +2195,15 @@ subroutine d_mv_csc_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine d_mv_csc_from_fmt_impl +end subroutine psb_d_mv_csc_from_fmt -subroutine d_cp_csc_from_fmt_impl(a,b,info) +subroutine psb_d_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csc_mat_mod, psb_protect_name => d_cp_csc_from_fmt_impl + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_from_fmt implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -2018,5 +2234,403 @@ subroutine d_cp_csc_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine d_cp_csc_from_fmt_impl +end subroutine psb_d_cp_csc_from_fmt + + +subroutine psb_d_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_d_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_reallocate_nz + + + +subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetblk + implicit none + + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_csgetblk + +subroutine psb_d_csc_reinit(a,clear) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_reinit + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_reinit + +subroutine psb_d_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_trim + implicit none + class(psb_d_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + n = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_trim + +subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_d_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_allocate_mnnz + +subroutine psb_d_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_d_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_d_csc_print + +subroutine psb_d_csc_cp_from(a,b) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cp_from + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + type(psb_d_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csc_cp_from + +subroutine psb_d_csc_mv_from(a,b) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mv_from + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csc_mv_from + + diff --git a/base/serial/f03/psb_d_csr_impl.f03 b/base/serial/f03/psb_d_csr_impl.f03 index 7e01c7a1..2b85f6c3 100644 --- a/base/serial/f03/psb_d_csr_impl.f03 +++ b/base/serial/f03/psb_d_csr_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_d_csr_mat_mod, psb_protect_name => d_csr_csmv_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csmv implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -57,7 +57,20 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - call d_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + if (size(x,1) d_csr_csmm_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csmm implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -340,6 +353,18 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) d_csr_cssv_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cssv implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -799,14 +824,14 @@ contains end if end subroutine inner_csrsv -end subroutine d_csr_cssv_impl +end subroutine psb_d_csr_cssv -subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_d_csr_mat_mod, psb_protect_name => d_csr_cssm_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cssm implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1017,11 +1042,11 @@ contains end if end subroutine inner_csrsm -end subroutine d_csr_cssm_impl +end subroutine psb_d_csr_cssm -function d_csr_csnmi_impl(a) result(res) +function psb_d_csr_csnmi(a) result(res) use psb_error_mod - use psb_d_csr_mat_mod, psb_protect_name => d_csr_csnmi_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csnmi implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1034,39 +1059,267 @@ function d_csr_csnmi_impl(a) result(res) logical, parameter :: debug=.false. - res = dzero - - do i = 1, a%get_nrows() - acc = dzero - do j=a%irp(i),a%irp(i+1)-1 - acc = acc + abs(a%val(j)) - end do - res = max(res,acc) - end do + res = dzero + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_d_csr_csnmi + +subroutine psb_d_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_get_diag + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_get_diag + + +subroutine psb_d_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scal + implicit none + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_scal + + +subroutine psb_d_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scals + implicit none + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_scals + + + + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine psb_d_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_d_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_reallocate_nz + + +subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_d_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if -end function d_csr_csnmi_impl + call psb_erractionrestore(err_act) + return -!===================================== -! -! -! -! Data management -! -! -! -! -! -!===================================== +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_allocate_mnnz -subroutine d_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_csr_csgetptn_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetptn implicit none class(psb_d_csr_sparse_mat), intent(in) :: a @@ -1231,17 +1484,17 @@ contains end subroutine csr_getptn -end subroutine d_csr_csgetptn_impl +end subroutine psb_d_csr_csgetptn -subroutine d_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_csr_csgetrow_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetrow implicit none class(psb_d_csr_sparse_mat), intent(in) :: a @@ -1412,14 +1665,73 @@ contains end subroutine csr_getrow -end subroutine d_csr_csgetrow_impl +end subroutine psb_d_csr_csgetrow + +subroutine psb_d_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetblk + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_d_csr_csgetblk -subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + + +subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_d_csr_mat_mod, psb_protect_name => d_csr_csput_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -1434,7 +1746,38 @@ subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1442,9 +1785,9 @@ subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call d_csr_srch_upd(nz,ia,ja,val,a,& + call psb_d_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1474,7 +1817,7 @@ subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine d_csr_srch_upd(nz,ia,ja,val,a,& + subroutine psb_d_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -1667,17 +2010,181 @@ contains end if - end subroutine d_csr_srch_upd + end subroutine psb_d_csr_srch_upd + +end subroutine psb_d_csr_csput + + +subroutine psb_d_csr_reinit(a,clear) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reinit + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_reinit + +subroutine psb_d_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_trim + implicit none + class(psb_d_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + m = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(m+1,a%irp,info) + + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_trim + +subroutine psb_d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_d_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif -end subroutine d_csr_csput_impl + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif +end subroutine psb_d_csr_print -subroutine d_cp_csr_from_coo_impl(a,b,info) +subroutine psb_d_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_from_coo_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_coo implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -1690,7 +2197,7 @@ subroutine d_cp_csr_from_coo_impl(a,b,info) logical :: rwshr_ Integer :: nza, nr, i,j,irw, idl,err_act, nc Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit + integer :: debug_level, debug_unit character(len=20) :: name info = 0 @@ -1698,18 +2205,18 @@ subroutine d_cp_csr_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine d_cp_csr_from_coo_impl +end subroutine psb_d_cp_csr_from_coo -subroutine d_cp_csr_to_coo_impl(a,b,info) +subroutine psb_d_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_coo_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_coo implicit none class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1740,18 +2247,18 @@ subroutine d_cp_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine d_cp_csr_to_coo_impl +end subroutine psb_d_cp_csr_to_coo -subroutine d_mv_csr_to_coo_impl(a,b,info) +subroutine psb_d_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_to_coo_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_coo implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(out) :: b + class(psb_d_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1783,15 +2290,15 @@ subroutine d_mv_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine d_mv_csr_to_coo_impl +end subroutine psb_d_mv_csr_to_coo -subroutine d_mv_csr_from_coo_impl(a,b,info) +subroutine psb_d_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_coo_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_coo implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -1874,18 +2381,17 @@ subroutine d_mv_csr_from_coo_impl(a,b,info) endif -end subroutine d_mv_csr_from_coo_impl +end subroutine psb_d_mv_csr_from_coo -subroutine d_mv_csr_to_fmt_impl(a,b,info) +subroutine psb_d_mv_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_to_fmt_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_fmt implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1914,18 +2420,17 @@ subroutine d_mv_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine d_mv_csr_to_fmt_impl +end subroutine psb_d_mv_csr_to_fmt -subroutine d_cp_csr_to_fmt_impl(a,b,info) +subroutine psb_d_cp_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_fmt_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_fmt implicit none class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b + class(psb_d_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1954,14 +2459,13 @@ subroutine d_cp_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine d_cp_csr_to_fmt_impl +end subroutine psb_d_cp_csr_to_fmt -subroutine d_mv_csr_from_fmt_impl(a,b,info) +subroutine psb_d_mv_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_fmt_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_fmt implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -1994,15 +2498,14 @@ subroutine d_mv_csr_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine d_mv_csr_from_fmt_impl +end subroutine psb_d_mv_csr_from_fmt -subroutine d_cp_csr_from_fmt_impl(a,b,info) +subroutine psb_d_cp_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_from_fmt_impl + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_fmt implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -2033,5 +2536,82 @@ subroutine d_cp_csr_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine d_cp_csr_from_fmt_impl +end subroutine psb_d_cp_csr_from_fmt + + +subroutine psb_d_csr_cp_from(a,b) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + type(psb_d_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csr_cp_from + +subroutine psb_d_csr_mv_from(a,b) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + type(psb_d_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csr_mv_from + diff --git a/base/serial/f03/psb_d_mat_impl.f03 b/base/serial/f03/psb_d_mat_impl.f03 new file mode 100644 index 00000000..5853b363 --- /dev/null +++ b/base/serial/f03/psb_d_mat_impl.f03 @@ -0,0 +1,1990 @@ +!===================================== +! +! +! +! Setters +! +! +! +! +! +! +!===================================== + + +subroutine psb_d_set_nrows(m,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_nrows + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_nrows + + +subroutine psb_d_set_ncols(n,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_ncols + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_ncols + + + +subroutine psb_d_set_state(n,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_state + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_state + + + +subroutine psb_d_set_dupl(n,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_dupl + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_dupl + + +subroutine psb_d_set_null(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_null + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_null + + +subroutine psb_d_set_bld(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_bld + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_bld + + +subroutine psb_d_set_upd(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_upd + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +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 + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_asb + + +subroutine psb_d_set_sorted(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_sorted + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_sorted + + +subroutine psb_d_set_triangle(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_triangle + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_triangle + + +subroutine psb_d_set_unit(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_unit + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_lower + + +subroutine psb_d_set_upper(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_upper + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_upper + + + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine psb_d_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_d_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 0 + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_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 + implicit none + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_get_neigh + + + +subroutine psb_d_csall(nr,nc,a,info,nz) + use psb_d_mat_mod, psb_protect_name => psb_d_csall + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + allocate(psb_d_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csall + + +subroutine psb_d_reallocate_nz(nz,a) + use psb_d_mat_mod, psb_protect_name => psb_d_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_reallocate_nz + + +subroutine psb_d_free(a) + use psb_d_mat_mod, psb_protect_name => psb_d_free + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%free() + deallocate(a%a) + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_free + + +subroutine psb_d_trim(a) + use psb_d_mat_mod, psb_protect_name => psb_d_trim + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_trim + + + +subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_mat_mod, psb_protect_name => psb_d_csput + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csput + + +subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csgetptn + implicit none + + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csgetptn + + +subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csgetrow + implicit none + + class(psb_d_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csgetblk + implicit none + + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + + if (info == 0) call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csgetblk + + + + +subroutine psb_d_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csclip + implicit none + + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csclip + + +subroutine psb_d_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_b_csclip + implicit none + + class(psb_d_sparse_mat), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_b_csclip + + + + +subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cscnv + implicit none + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + + + class(psb_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_cscnv + + + +subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_ip + implicit none + + class(psb_d_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + + + class(psb_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + 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 = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_cscnv_ip + + + +subroutine psb_d_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_base + implicit none + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_d_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == 0).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == 0) call altmp%trim() + if (info == 0) call altmp%set_asb() + if (info == 0) call b%mv_from_coo(altmp,info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_cscnv_base + + + +subroutine psb_d_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_clip_d + implicit none + + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%cp_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_clip_d + + + +subroutine psb_d_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_clip_d_ip + implicit none + + class(psb_d_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%mv_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_clip_d_ip + + +subroutine psb_d_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_from + implicit none + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer :: info + + allocate(a%a,source=b, stat=info) + call a%a%mv_from_fmt(b,info) + + return +end subroutine psb_d_mv_from + + +subroutine psb_d_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_from + implicit none + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(a%a,source=b,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call a%a%cp_from_fmt(b, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_d_cp_from + + +subroutine psb_d_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_to + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_d_mv_to + + +subroutine psb_d_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_to + implicit none + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_d_cp_to + + + +subroutine psb_d_sparse_mat_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_sparse_mat_move + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = 0 + call move_alloc(a%a,b%a) + + return +end subroutine psb_d_sparse_mat_move + + +subroutine psb_d_sparse_mat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_sparse_mat_clone + implicit none + class(psb_d_sparse_mat), intent(in) :: a + class(psb_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(b%a,source=a%a,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call b%a%cp_from_fmt(a%a, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_sparse_mat_clone + + + +subroutine psb_d_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transp_1mat + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transp_1mat + + + +subroutine psb_d_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transp_2mat + implicit none + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transp_2mat + + +subroutine psb_d_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transc_1mat + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transc_1mat + + + +subroutine psb_d_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transc_2mat + implicit none + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transc_2mat + + + + +subroutine psb_d_reinit(a,clear) + use psb_d_mat_mod, psb_protect_name => psb_d_reinit + use psb_error_mod + implicit none + + class(psb_d_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_reinit + + + + +!===================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!===================================== + + +subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csmm + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csmm + + +subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csmv + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csmv + + +subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cssm + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cssm + + +subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cssv + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cssv + + + +function psb_d_csnmi(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_d_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_d_csnmi + + +subroutine psb_d_get_diag(a,d,info) + use psb_d_mat_mod, psb_protect_name => psb_d_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_get_diag + + +subroutine psb_d_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_scal + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_scal + + +subroutine psb_d_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_scals + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_scals + + + diff --git a/base/serial/f03/psb_s_base_mat_impl.f03 b/base/serial/f03/psb_s_base_mat_impl.f03 new file mode 100644 index 00000000..e544acba --- /dev/null +++ b/base/serial/f03/psb_s_base_mat_impl.f03 @@ -0,0 +1,1078 @@ +!==================================== +! +! +! +! Data management +! +! +! +! +! +!==================================== + +subroutine psb_s_base_cp_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_to_coo + +subroutine psb_s_base_cp_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_from_coo + + +subroutine psb_s_base_cp_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_to_fmt + +subroutine psb_s_base_cp_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_from_fmt + + +subroutine psb_s_base_mv_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_to_coo + +subroutine psb_s_base_mv_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_from_coo + + +subroutine psb_s_base_mv_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_to_fmt + +subroutine psb_s_base_mv_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_from_fmt + +subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_csput + +subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csgetrow + implicit none + + class(psb_s_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_csgetrow + + + +subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csgetblk + implicit none + + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_base_csgetblk + + +subroutine psb_s_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csclip + implicit none + + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_base_csclip + + +subroutine psb_s_base_transp_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_s_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='s_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_s_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + class default + info = 700 + end select + if (info /= 0) then + call psb_errpush(info,name,a_err=b%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_transp_2mat + +subroutine psb_s_base_transc_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transc_2mat + implicit none + + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) +end subroutine psb_s_base_transc_2mat + +subroutine psb_s_base_transp_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(inout) :: a + + type(psb_s_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='s_base_transp' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + + if (info /= 0) then + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_transp_1mat + +subroutine psb_s_base_transc_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transc_1mat + implicit none + + class(psb_s_base_sparse_mat), intent(inout) :: a + + call a%transp() +end subroutine psb_s_base_transc_1mat + + +!==================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!==================================== + +subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmm + use psb_error_mod + + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_csmm + + +subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmv + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_s_base_csmv + + +subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_cssm + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_inner_cssm + + +subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_cssv + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_inner_cssv + + +subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + + real(psb_spk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='s_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(sone,x,szero,tmp,info,trans) + + if (info == 0)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == 0)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_s_base_cssm + + +subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + + real(psb_spk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='s_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= 0) info = 4000 + if (info == 0) call inner_vscal(nac,d,x,tmp) + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == szero) then + call a%inner_cssm(alpha,x,szero,y,info,trans) + if (info == 0) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(alpha,x,szero,tmp,info,trans) + + if (info == 0) call inner_vscal1(nar,d,tmp) + if (info == 0)& + & call psb_geaxpby(nar,sone,tmp,beta,y,info) + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + real(psb_spk_), intent(in) :: d(*),x(*) + real(psb_spk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + real(psb_spk_), intent(in) :: d(*) + real(psb_spk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_s_base_cssv + + +subroutine psb_s_base_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scals + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_scals + + + +subroutine psb_s_base_scal(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scal + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_scal + + + +function psb_s_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csnmi + + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -sone + + return + +end function psb_s_base_csnmi + +subroutine psb_s_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_get_diag + + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_get_diag + + + + diff --git a/base/serial/f03/psb_s_coo_impl.f03 b/base/serial/f03/psb_s_coo_impl.f03 index ccb4dcee..30f6aa58 100644 --- a/base/serial/f03/psb_s_coo_impl.f03 +++ b/base/serial/f03/psb_s_coo_impl.f03 @@ -1,9 +1,439 @@ -subroutine s_coo_cssm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_get_diag(a,d,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = szero + + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_get_diag + + +subroutine psb_s_coo_scal(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scal + use psb_error_mod use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_scal + + +subroutine psb_s_coo_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_scals + + +subroutine psb_s_coo_reallocate_nz(nz,a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_s_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='s_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_reallocate_nz + + + +subroutine psb_s_coo_reinit(a,clear) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reinit + use psb_error_mod + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_reinit + + + +subroutine psb_s_coo_trim(a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_trim + use psb_realloc_mod use psb_error_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + nz = a%get_nzeros() + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_trim + + +subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_s_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_allocate_mnnz + + + +subroutine psb_s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_print use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_cssm_impl + implicit none + + integer, intent(in) :: iout + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='s_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_s_coo_print + + + + +function psb_s_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_nz_row + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_s_coo_get_nz_row + +subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cssm implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -43,10 +473,20 @@ subroutine s_coo_cssm_impl(alpha,a,x,beta,y,info,trans) end if tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() - if (alpha == szero) then if (beta == szero) then do i = 1, m @@ -113,6 +553,7 @@ contains real(psb_spk_), intent(in) :: val(*), x(ldx,*) real(psb_spk_), intent(out) :: y(ldy,*) integer, intent(out) :: info + integer :: i,j,k,m, ir, jc real(psb_spk_), allocatable :: acc(:) @@ -270,15 +711,15 @@ contains end if end subroutine inner_coosm -end subroutine s_coo_cssm_impl +end subroutine psb_s_coo_cssm -subroutine s_coo_cssv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_cssv_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cssv implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -311,7 +752,16 @@ subroutine s_coo_cssv_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if if (.not. (a%is_triangle())) then info = 1121 call psb_errpush(info,name) @@ -538,13 +988,13 @@ contains end subroutine inner_coosv -end subroutine s_coo_cssv_impl +end subroutine psb_s_coo_cssv -subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_csMv_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csmv implicit none class(psb_s_coo_sparse_mat), intent(in) :: a @@ -579,6 +1029,7 @@ subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + if (tra) then m = a%get_ncols() n = a%get_nrows() @@ -586,6 +1037,16 @@ subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if nnz = a%get_nzeros() if (alpha == szero) then @@ -694,14 +1155,14 @@ subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine s_coo_csmv_impl +end subroutine psb_s_coo_csmv -subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_csmm_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csmm implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -734,6 +1195,7 @@ subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') if (tra) then @@ -743,6 +1205,17 @@ subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() nc = min(size(x,2), size(y,2)) @@ -859,11 +1332,11 @@ subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine s_coo_csmm_impl +end subroutine psb_s_coo_csmm -function s_coo_csnmi_impl(a) result(res) +function psb_s_coo_csnmi(a) result(res) use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_csnmi_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csnmi implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -884,7 +1357,7 @@ function s_coo_csnmi_impl(a) result(res) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - acc = szero + acc = szero do k=i, j-1 acc = acc + abs(a%val(k)) end do @@ -892,7 +1365,7 @@ function s_coo_csnmi_impl(a) result(res) i = j end do -end function s_coo_csnmi_impl +end function psb_s_coo_csnmi @@ -910,13 +1383,13 @@ end function s_coo_csnmi_impl -subroutine s_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_csgetptn_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csgetptn implicit none class(psb_s_coo_sparse_mat), intent(in) :: a @@ -929,7 +1402,7 @@ subroutine s_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: appens_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -954,11 +1427,11 @@ subroutine s_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& end if if (present(append)) then - appens_=append + append_=append else - appens_=.false. + append_=.false. endif - if ((appens_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 @@ -979,9 +1452,9 @@ subroutine s_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& goto 9999 end if - call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,appens_,info,& + call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1181,16 +1654,16 @@ contains end subroutine coo_getptn -end subroutine s_coo_csgetptn_impl +end subroutine psb_s_coo_csgetptn -subroutine s_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_csgetrow_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csgetrow implicit none class(psb_s_coo_sparse_mat), intent(in) :: a @@ -1204,7 +1677,7 @@ subroutine s_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& integer, intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: appens_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -1229,11 +1702,11 @@ subroutine s_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& end if if (present(append)) then - appens_=append + append_=append else - appens_=.false. + append_=.false. endif - if ((appens_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 @@ -1254,9 +1727,9 @@ subroutine s_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& goto 9999 end if - call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,appens_,info,& + call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1465,16 +1938,16 @@ contains end subroutine coo_getrow -end subroutine s_coo_csgetrow_impl +end subroutine psb_s_coo_csgetrow -subroutine s_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod use psb_sort_mod - use psb_s_base_mat_mod, psb_protect_name => s_coo_csput_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csput implicit none - + class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -1489,7 +1962,7 @@ subroutine s_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 0 call psb_erractionsave(err_act) - + if (nz <= 0) then info = 10 int_err(1)=1 @@ -1532,7 +2005,7 @@ subroutine s_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info,gtl) call a%set_nzeros(nza) call a%set_sorted(.false.) - + else if (a%is_upd()) then @@ -1842,18 +2315,176 @@ contains end if - end subroutine s_coo_srch_upd + end subroutine s_coo_srch_upd + +end subroutine psb_s_coo_csput + + +subroutine psb_s_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_coo + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + b%ia(:) = a%ia(:) + b%ja(:) = a%ja(:) + b%val(:) = a%val(:) + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_to_coo + +subroutine psb_s_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_coo + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_from_coo + + +subroutine psb_s_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_fmt + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_to_fmt + +subroutine psb_s_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_fmt + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return -end subroutine s_coo_csput_impl +end subroutine psb_s_cp_coo_from_fmt -subroutine s_cp_coo_to_coo_impl(a,b,info) +subroutine psb_s_mv_coo_to_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_cp_coo_to_coo_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_to_coo implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1863,14 +2494,14 @@ subroutine s_cp_coo_to_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) - + call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) - b%ia(:) = a%ia(:) - b%ja(:) = a%ja(:) - b%val(:) = a%val(:) + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() call b%fix(info) @@ -1889,15 +2520,14 @@ subroutine s_cp_coo_to_coo_impl(a,b,info) end if return -end subroutine s_cp_coo_to_coo_impl - -subroutine s_cp_coo_from_coo_impl(a,b,info) +end subroutine psb_s_mv_coo_to_coo + +subroutine psb_s_mv_coo_from_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_cp_coo_from_coo_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_from_coo implicit none - class(psb_s_coo_sparse_mat), intent(out) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1908,14 +2538,14 @@ subroutine s_cp_coo_from_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) - a%ia(:) = b%ia(:) - a%ja(:) = b%ja(:) - a%val(:) = b%val(:) - + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() call a%fix(info) if (info /= 0) goto 9999 @@ -1933,16 +2563,15 @@ subroutine s_cp_coo_from_coo_impl(a,b,info) end if return -end subroutine s_cp_coo_from_coo_impl +end subroutine psb_s_mv_coo_from_coo -subroutine s_cp_coo_to_fmt_impl(a,b,info) +subroutine psb_s_mv_coo_to_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_cp_coo_to_fmt_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_to_fmt implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1953,7 +2582,7 @@ subroutine s_cp_coo_to_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_from_coo(a,info) + call b%mv_from_coo(a,info) if (info /= 0) goto 9999 @@ -1970,15 +2599,14 @@ subroutine s_cp_coo_to_fmt_impl(a,b,info) end if return -end subroutine s_cp_coo_to_fmt_impl - -subroutine s_cp_coo_from_fmt_impl(a,b,info) +end subroutine psb_s_mv_coo_to_fmt + +subroutine psb_s_mv_coo_from_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_cp_coo_from_fmt_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_from_fmt implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(in) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -1990,8 +2618,74 @@ subroutine s_cp_coo_from_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_to_coo(a,info) + call b%mv_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_mv_coo_from_fmt + +subroutine psb_s_coo_cp_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cp_from + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + type(psb_s_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%cp_from_coo(b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_coo_cp_from + +subroutine psb_s_coo_mv_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mv_from + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%mv_from_coo(b,info) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -2007,16 +2701,14 @@ subroutine s_cp_coo_from_fmt_impl(a,b,info) end if return -end subroutine s_cp_coo_from_fmt_impl +end subroutine psb_s_coo_mv_from + -subroutine s_fix_coo_impl(a,info,idir) +subroutine psb_s_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_string_mod - use psb_ip_reord_mod - use psb_s_base_mat_mod, psb_protect_name => s_fix_coo_impl + use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a @@ -2049,12 +2741,12 @@ subroutine s_fix_coo_impl(a,info,idir) dupl_ = a%get_dupl() - call s_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - + call psb_s_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= 0) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() - + call psb_erractionrestore(err_act) return @@ -2067,19 +2759,18 @@ subroutine s_fix_coo_impl(a,info,idir) end if return -end subroutine s_fix_coo_impl +end subroutine psb_s_fix_coo -subroutine s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_fix_coo_inner + use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo_inner use psb_string_mod use psb_ip_reord_mod implicit none - + integer, intent(in) :: nzin, dupl integer, intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) @@ -2111,7 +2802,7 @@ subroutine s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (nzin < 2) return dupl_ = dupl - + allocate(iaux(nzin+2),stat=info) if (info /= 0) return @@ -2288,7 +2979,7 @@ subroutine s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) end select nzout = i - + deallocate(iaux) call psb_erractionrestore(err_act) @@ -2304,169 +2995,5 @@ subroutine s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) -end subroutine s_fix_coo_inner - - - - -subroutine s_mv_coo_to_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_mv_coo_to_coo_impl - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) - call b%set_nzeros(a%get_nzeros()) - call b%reallocate(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call a%free() - - call b%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine s_mv_coo_to_coo_impl - -subroutine s_mv_coo_from_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_mv_coo_from_coo_impl - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) - call a%set_nzeros(b%get_nzeros()) - call a%reallocate(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine s_mv_coo_from_coo_impl - - -subroutine s_mv_coo_to_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_mv_coo_to_fmt_impl - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_from_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine s_mv_coo_to_fmt_impl - -subroutine s_mv_coo_from_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_s_base_mat_mod, psb_protect_name => s_mv_coo_from_fmt_impl - implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_to_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return +end subroutine psb_s_fix_coo_inner -end subroutine s_mv_coo_from_fmt_impl diff --git a/base/serial/f03/psb_s_csc_impl.f03 b/base/serial/f03/psb_s_csc_impl.f03 index f3d337ff..03b706df 100644 --- a/base/serial/f03/psb_s_csc_impl.f03 +++ b/base/serial/f03/psb_s_csc_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine s_csc_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_s_csc_mat_mod, psb_protect_name => s_csc_csmv_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csmv implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -58,10 +58,23 @@ subroutine s_csc_csmv_impl(alpha,a,x,beta,y,info,trans) end if - if (alpha == szero) then - if (beta == szero) then + if (size(x,1) s_csc_csmm_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csmm implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -319,6 +332,19 @@ subroutine s_csc_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) s_csc_cssv_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cssv implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -589,11 +615,24 @@ subroutine s_csc_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x,1) s_csc_cssm_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cssm implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -788,6 +831,19 @@ subroutine s_csc_cssm_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() + + if (size(x,1) s_csc_csnmi_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csnmi implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -982,14 +1041,14 @@ function s_csc_csnmi_impl(a) result(res) logical, parameter :: debug=.false. - res = szero + res = dzero nr = a%get_nrows() nc = a%get_ncols() allocate(acc(nr),stat=info) if (info /= 0) then return end if - acc(:) = szero + acc(:) = dzero do i=1, nc do j=a%icp(i),a%icp(i+1)-1 acc(a%ia(j)) = acc(a%ia(j)) + abs(a%val(j)) @@ -1000,7 +1059,135 @@ function s_csc_csnmi_impl(a) result(res) end do deallocate(acc) -end function s_csc_csnmi_impl +end function psb_s_csc_csnmi + + +subroutine psb_s_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_get_diag + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_get_diag + + +subroutine psb_s_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scal + implicit none + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_scal + + +subroutine psb_s_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scals + implicit none + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_scals + !===================================== ! @@ -1014,14 +1201,14 @@ end function s_csc_csnmi_impl ! !===================================== -subroutine s_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_csc_csgetptn_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetptn implicit none class(psb_s_csc_sparse_mat), intent(in) :: a @@ -1197,19 +1384,19 @@ contains end subroutine csc_getptn -end subroutine s_csc_csgetptn_impl +end subroutine psb_s_csc_csgetptn -subroutine s_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_csc_csgetrow_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetrow implicit none class(psb_s_csc_sparse_mat), intent(in) :: a @@ -1392,14 +1579,14 @@ contains end if end subroutine csc_getrow -end subroutine s_csc_csgetrow_impl +end subroutine psb_s_csc_csgetrow -subroutine s_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_s_csc_mat_mod, psb_protect_name => s_csc_csput_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -1414,7 +1601,37 @@ subroutine s_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1422,9 +1639,9 @@ subroutine s_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call s_csc_srch_upd(nz,ia,ja,val,a,& + call psb_s_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1454,7 +1671,7 @@ subroutine s_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine s_csc_srch_upd(nz,ia,ja,val,a,& + subroutine psb_s_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -1652,17 +1869,17 @@ contains end if - end subroutine s_csc_srch_upd + end subroutine psb_s_csc_srch_upd -end subroutine s_csc_csput_impl +end subroutine psb_s_csc_csput -subroutine s_cp_csc_from_coo_impl(a,b,info) +subroutine psb_s_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_cp_csc_from_coo_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_from_coo implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -1683,18 +1900,18 @@ subroutine s_cp_csc_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine s_cp_csc_from_coo_impl +end subroutine psb_s_cp_csc_from_coo -subroutine s_cp_csc_to_coo_impl(a,b,info) +subroutine psb_s_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_cp_csc_to_coo_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_to_coo implicit none class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1726,18 +1943,18 @@ subroutine s_cp_csc_to_coo_impl(a,b,info) call b%fix(info) -end subroutine s_cp_csc_to_coo_impl +end subroutine psb_s_cp_csc_to_coo -subroutine s_mv_csc_to_coo_impl(a,b,info) +subroutine psb_s_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_mv_csc_to_coo_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_to_coo implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1768,15 +1985,15 @@ subroutine s_mv_csc_to_coo_impl(a,b,info) call a%free() call b%fix(info) -end subroutine s_mv_csc_to_coo_impl +end subroutine psb_s_mv_csc_to_coo -subroutine s_mv_csc_from_coo_impl(a,b,info) +subroutine psb_s_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_mv_csc_from_coo_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_coo implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -1859,18 +2076,18 @@ subroutine s_mv_csc_from_coo_impl(a,b,info) endif -end subroutine s_mv_csc_from_coo_impl +end subroutine psb_s_mv_csc_from_coo -subroutine s_mv_csc_to_fmt_impl(a,b,info) +subroutine psb_s_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_mv_csc_to_fmt_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_to_fmt implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1899,18 +2116,18 @@ subroutine s_mv_csc_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine s_mv_csc_to_fmt_impl +end subroutine psb_s_mv_csc_to_fmt !!$ -subroutine s_cp_csc_to_fmt_impl(a,b,info) +subroutine psb_s_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_cp_csc_to_fmt_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_to_fmt implicit none class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1934,22 +2151,19 @@ subroutine s_cp_csc_to_fmt_impl(a,b,info) b%ia = a%ia b%val = a%val -!!$ type is (psb_s_csc_sparse_mat) -!!$ b = a - class default call tmp%cp_from_fmt(a,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine s_cp_csc_to_fmt_impl +end subroutine psb_s_cp_csc_to_fmt -subroutine s_mv_csc_from_fmt_impl(a,b,info) +subroutine psb_s_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_mv_csc_from_fmt_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_fmt implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -1982,15 +2196,15 @@ subroutine s_mv_csc_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine s_mv_csc_from_fmt_impl +end subroutine psb_s_mv_csc_from_fmt -subroutine s_cp_csc_from_fmt_impl(a,b,info) +subroutine psb_s_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csc_mat_mod, psb_protect_name => s_cp_csc_from_fmt_impl + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_from_fmt implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -2021,5 +2235,403 @@ subroutine s_cp_csc_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine s_cp_csc_from_fmt_impl +end subroutine psb_s_cp_csc_from_fmt + + +subroutine psb_s_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_s_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='s_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_reallocate_nz + + + +subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetblk + implicit none + + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_csgetblk + +subroutine psb_s_csc_reinit(a,clear) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_reinit + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_reinit + +subroutine psb_s_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_trim + implicit none + class(psb_s_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + n = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_trim + +subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_s_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_allocate_mnnz + +subroutine psb_s_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_s_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='s_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_s_csc_print + +subroutine psb_s_csc_cp_from(a,b) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cp_from + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + type(psb_s_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csc_cp_from + +subroutine psb_s_csc_mv_from(a,b) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mv_from + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csc_mv_from + + diff --git a/base/serial/f03/psb_s_csr_impl.f03 b/base/serial/f03/psb_s_csr_impl.f03 index 6a2c5e75..4a9d9ec4 100644 --- a/base/serial/f03/psb_s_csr_impl.f03 +++ b/base/serial/f03/psb_s_csr_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine s_csr_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_s_csr_mat_mod, psb_protect_name => s_csr_csmv_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csmv implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -57,7 +57,20 @@ subroutine s_csr_csmv_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - call s_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + if (size(x,1) s_csr_csmm_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csmm implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -340,6 +353,18 @@ subroutine s_csr_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) s_csr_cssv_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cssv implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -641,10 +666,10 @@ subroutine s_csr_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if - if (alpha == szero) then - if (beta == szero) then + if (alpha == dzero) then + if (beta == dzero) then do i = 1, m - y(i) = szero + y(i) = dzero enddo else do i = 1, m @@ -654,13 +679,13 @@ subroutine s_csr_cssv_impl(alpha,a,x,beta,y,info,trans) return end if - if (beta == szero) then + if (beta == dzero) then call inner_csrsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),& & a%irp,a%ja,a%val,x,y) - if (alpha == sone) then + if (alpha == done) then ! do nothing - else if (alpha == -sone) then + else if (alpha == -done) then do i = 1, m y(i) = -y(i) end do @@ -712,7 +737,7 @@ contains if (lower) then if (unit) then do i=1, n - acc = szero + acc = dzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j)) end do @@ -720,7 +745,7 @@ contains end do else if (.not.unit) then do i=1, n - acc = szero + acc = dzero do j=irp(i), irp(i+1)-2 acc = acc + val(j)*y(ja(j)) end do @@ -731,7 +756,7 @@ contains if (unit) then do i=n, 1, -1 - acc = szero + acc = dzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j)) end do @@ -739,7 +764,7 @@ contains end do else if (.not.unit) then do i=n, 1, -1 - acc = szero + acc = dzero do j=irp(i)+1, irp(i+1)-1 acc = acc + val(j)*y(ja(j)) end do @@ -799,14 +824,14 @@ contains end if end subroutine inner_csrsv -end subroutine s_csr_cssv_impl +end subroutine psb_s_csr_cssv -subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_s_csr_mat_mod, psb_protect_name => s_csr_cssm_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cssm implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -820,7 +845,7 @@ subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) real(psb_spk_), allocatable :: tmp(:,:) logical :: tra Integer :: err_act - character(len=20) :: name='s_base_cssm' + character(len=20) :: name='s_csr_cssm' logical, parameter :: debug=.false. info = 0 @@ -850,10 +875,10 @@ subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) end if - if (alpha == szero) then - if (beta == szero) then + if (alpha == dzero) then + if (beta == dzero) then do i = 1, m - y(i,:) = szero + y(i,:) = dzero enddo else do i = 1, m @@ -863,7 +888,7 @@ subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) return end if - if (beta == szero) then + if (beta == dzero) then call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& & a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info) do i = 1, m @@ -930,7 +955,7 @@ contains if (lower) then if (unit) then do i=1, nr - acc = szero + acc = dzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -938,7 +963,7 @@ contains end do else if (.not.unit) then do i=1, nr - acc = szero + acc = dzero do j=irp(i), irp(i+1)-2 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -949,7 +974,7 @@ contains if (unit) then do i=nr, 1, -1 - acc = szero + acc = dzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -957,7 +982,7 @@ contains end do else if (.not.unit) then do i=nr, 1, -1 - acc = szero + acc = dzero do j=irp(i)+1, irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -1017,11 +1042,11 @@ contains end if end subroutine inner_csrsm -end subroutine s_csr_cssm_impl +end subroutine psb_s_csr_cssm -function s_csr_csnmi_impl(a) result(res) +function psb_s_csr_csnmi(a) result(res) use psb_error_mod - use psb_s_csr_mat_mod, psb_protect_name => s_csr_csnmi_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csnmi implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1034,39 +1059,267 @@ function s_csr_csnmi_impl(a) result(res) logical, parameter :: debug=.false. - res = szero - - do i = 1, a%get_nrows() - acc = szero - do j=a%irp(i),a%irp(i+1)-1 - acc = acc + abs(a%val(j)) - end do - res = max(res,acc) - end do + res = dzero + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_s_csr_csnmi + +subroutine psb_s_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_get_diag + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_get_diag + + +subroutine psb_s_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scal + implicit none + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_scal + + +subroutine psb_s_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scals + implicit none + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_scals + + + + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine psb_s_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_s_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='s_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_reallocate_nz + + +subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_s_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if -end function s_csr_csnmi_impl + call psb_erractionrestore(err_act) + return -!===================================== -! -! -! -! Data management -! -! -! -! -! -!===================================== +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_allocate_mnnz -subroutine s_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_csr_csgetptn_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csgetptn implicit none class(psb_s_csr_sparse_mat), intent(in) :: a @@ -1231,17 +1484,17 @@ contains end subroutine csr_getptn -end subroutine s_csr_csgetptn_impl +end subroutine psb_s_csr_csgetptn -subroutine s_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_csr_csgetrow_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csgetrow implicit none class(psb_s_csr_sparse_mat), intent(in) :: a @@ -1262,7 +1515,7 @@ subroutine s_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& call psb_erractionsave(err_act) info = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1412,14 +1665,73 @@ contains end subroutine csr_getrow -end subroutine s_csr_csgetrow_impl +end subroutine psb_s_csr_csgetrow + +subroutine psb_s_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csgetblk + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_s_csr_csgetblk -subroutine s_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + + +subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_s_csr_mat_mod, psb_protect_name => s_csr_csput_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -1434,7 +1746,38 @@ subroutine s_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1442,9 +1785,9 @@ subroutine s_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call s_csr_srch_upd(nz,ia,ja,val,a,& + call psb_s_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1474,7 +1817,7 @@ subroutine s_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine s_csr_srch_upd(nz,ia,ja,val,a,& + subroutine psb_s_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -1667,17 +2010,181 @@ contains end if - end subroutine s_csr_srch_upd + end subroutine psb_s_csr_srch_upd + +end subroutine psb_s_csr_csput + + +subroutine psb_s_csr_reinit(a,clear) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_reinit + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_reinit + +subroutine psb_s_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_trim + implicit none + class(psb_s_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + m = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(m+1,a%irp,info) + + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_trim + +subroutine psb_s_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_s_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='s_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif -end subroutine s_csr_csput_impl + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif +end subroutine psb_s_csr_print -subroutine s_cp_csr_from_coo_impl(a,b,info) +subroutine psb_s_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_cp_csr_from_coo_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_coo implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -1690,7 +2197,7 @@ subroutine s_cp_csr_from_coo_impl(a,b,info) logical :: rwshr_ Integer :: nza, nr, i,j,irw, idl,err_act, nc Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit + integer :: debug_level, debug_unit character(len=20) :: name info = 0 @@ -1698,18 +2205,18 @@ subroutine s_cp_csr_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine s_cp_csr_from_coo_impl +end subroutine psb_s_cp_csr_from_coo -subroutine s_cp_csr_to_coo_impl(a,b,info) +subroutine psb_s_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_cp_csr_to_coo_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_to_coo implicit none class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1740,18 +2247,18 @@ subroutine s_cp_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine s_cp_csr_to_coo_impl +end subroutine psb_s_cp_csr_to_coo -subroutine s_mv_csr_to_coo_impl(a,b,info) +subroutine psb_s_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_mv_csr_to_coo_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_to_coo implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(out) :: b + class(psb_s_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1783,15 +2290,15 @@ subroutine s_mv_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine s_mv_csr_to_coo_impl +end subroutine psb_s_mv_csr_to_coo -subroutine s_mv_csr_from_coo_impl(a,b,info) +subroutine psb_s_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_mv_csr_from_coo_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_coo implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -1874,18 +2381,17 @@ subroutine s_mv_csr_from_coo_impl(a,b,info) endif -end subroutine s_mv_csr_from_coo_impl +end subroutine psb_s_mv_csr_from_coo -subroutine s_mv_csr_to_fmt_impl(a,b,info) +subroutine psb_s_mv_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_mv_csr_to_fmt_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_to_fmt implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1914,18 +2420,17 @@ subroutine s_mv_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine s_mv_csr_to_fmt_impl +end subroutine psb_s_mv_csr_to_fmt -subroutine s_cp_csr_to_fmt_impl(a,b,info) +subroutine psb_s_cp_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_cp_csr_to_fmt_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_to_fmt implicit none class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b + class(psb_s_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -1954,14 +2459,13 @@ subroutine s_cp_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine s_cp_csr_to_fmt_impl +end subroutine psb_s_cp_csr_to_fmt -subroutine s_mv_csr_from_fmt_impl(a,b,info) +subroutine psb_s_mv_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_mv_csr_from_fmt_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_fmt implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -1994,15 +2498,14 @@ subroutine s_mv_csr_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine s_mv_csr_from_fmt_impl +end subroutine psb_s_mv_csr_from_fmt -subroutine s_cp_csr_from_fmt_impl(a,b,info) +subroutine psb_s_cp_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, psb_protect_name => s_cp_csr_from_fmt_impl + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_fmt implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -2033,5 +2536,82 @@ subroutine s_cp_csr_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine s_cp_csr_from_fmt_impl +end subroutine psb_s_cp_csr_from_fmt + + +subroutine psb_s_csr_cp_from(a,b) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cp_from + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + type(psb_s_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csr_cp_from + +subroutine psb_s_csr_mv_from(a,b) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mv_from + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + type(psb_s_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csr_mv_from + diff --git a/base/serial/f03/psb_s_mat_impl.f03 b/base/serial/f03/psb_s_mat_impl.f03 new file mode 100644 index 00000000..1e91ad4a --- /dev/null +++ b/base/serial/f03/psb_s_mat_impl.f03 @@ -0,0 +1,1990 @@ +!===================================== +! +! +! +! Setters +! +! +! +! +! +! +!===================================== + + +subroutine psb_s_set_nrows(m,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_nrows + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_nrows + + +subroutine psb_s_set_ncols(n,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_ncols + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_ncols + + + +subroutine psb_s_set_state(n,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_state + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_state + + + +subroutine psb_s_set_dupl(n,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_dupl + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_dupl + + +subroutine psb_s_set_null(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_null + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_null + + +subroutine psb_s_set_bld(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_bld + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_bld + + +subroutine psb_s_set_upd(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_upd + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +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 + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_asb + + +subroutine psb_s_set_sorted(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_sorted + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_sorted + + +subroutine psb_s_set_triangle(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_triangle + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_triangle + + +subroutine psb_s_set_unit(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_unit + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_lower + + +subroutine psb_s_set_upper(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_upper + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_upper + + + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine psb_s_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_s_mat_mod, psb_protect_name => psb_s_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 0 + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_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 + implicit none + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_get_neigh + + + +subroutine psb_s_csall(nr,nc,a,info,nz) + use psb_s_mat_mod, psb_protect_name => psb_s_csall + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + allocate(psb_s_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csall + + +subroutine psb_s_reallocate_nz(nz,a) + use psb_s_mat_mod, psb_protect_name => psb_s_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_reallocate_nz + + +subroutine psb_s_free(a) + use psb_s_mat_mod, psb_protect_name => psb_s_free + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%free() + deallocate(a%a) + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_free + + +subroutine psb_s_trim(a) + use psb_s_mat_mod, psb_protect_name => psb_s_trim + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_trim + + + +subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_mat_mod, psb_protect_name => psb_s_csput + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csput + + +subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csgetptn + implicit none + + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csgetptn + + +subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csgetrow + implicit none + + class(psb_s_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csgetblk + implicit none + + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + + if (info == 0) call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csgetblk + + + + +subroutine psb_s_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csclip + implicit none + + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csclip + + +subroutine psb_s_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_b_csclip + implicit none + + class(psb_s_sparse_mat), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_b_csclip + + + + +subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cscnv + implicit none + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + + + class(psb_s_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_s_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_cscnv + + + +subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_ip + implicit none + + class(psb_s_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + + + class(psb_s_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + 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 = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_s_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_cscnv_ip + + + +subroutine psb_s_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_base + implicit none + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_s_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == 0).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == 0) call altmp%trim() + if (info == 0) call altmp%set_asb() + if (info == 0) call b%mv_from_coo(altmp,info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_cscnv_base + + + +subroutine psb_s_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_clip_d + implicit none + + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%cp_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_clip_d + + + +subroutine psb_s_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_clip_d_ip + implicit none + + class(psb_s_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%mv_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_clip_d_ip + + +subroutine psb_s_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_from + implicit none + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer :: info + + allocate(a%a,source=b, stat=info) + call a%a%mv_from_fmt(b,info) + + return +end subroutine psb_s_mv_from + + +subroutine psb_s_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_from + implicit none + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(a%a,source=b,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call a%a%cp_from_fmt(b, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_s_cp_from + + +subroutine psb_s_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_to + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_s_mv_to + + +subroutine psb_s_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_to + implicit none + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_s_cp_to + + + +subroutine psb_s_sparse_mat_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_sparse_mat_move + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = 0 + call move_alloc(a%a,b%a) + + return +end subroutine psb_s_sparse_mat_move + + +subroutine psb_s_sparse_mat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_sparse_mat_clone + implicit none + class(psb_s_sparse_mat), intent(in) :: a + class(psb_s_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(b%a,source=a%a,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call b%a%cp_from_fmt(a%a, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_sparse_mat_clone + + + +subroutine psb_s_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transp_1mat + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transp_1mat + + + +subroutine psb_s_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transp_2mat + implicit none + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transp_2mat + + +subroutine psb_s_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transc_1mat + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transc_1mat + + + +subroutine psb_s_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transc_2mat + implicit none + class(psb_s_sparse_mat), intent(out) :: a + class(psb_s_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transc_2mat + + + + +subroutine psb_s_reinit(a,clear) + use psb_s_mat_mod, psb_protect_name => psb_s_reinit + use psb_error_mod + implicit none + + class(psb_s_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_reinit + + + + +!===================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!===================================== + + +subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csmm + implicit none + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csmm + + +subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csmv + implicit none + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csmv + + +subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cssm + implicit none + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_cssm + + +subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cssv + implicit none + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_cssv + + + +function psb_s_csnmi(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_s_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_s_csnmi + + +subroutine psb_s_get_diag(a,d,info) + use psb_s_mat_mod, psb_protect_name => psb_s_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_get_diag + + +subroutine psb_s_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_scal + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_scal + + +subroutine psb_s_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_scals + implicit none + class(psb_s_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_scals + + + diff --git a/base/serial/f03/psb_z_base_mat_impl.f03 b/base/serial/f03/psb_z_base_mat_impl.f03 new file mode 100644 index 00000000..e7f90efd --- /dev/null +++ b/base/serial/f03/psb_z_base_mat_impl.f03 @@ -0,0 +1,1078 @@ +!==================================== +! +! +! +! Data management +! +! +! +! +! +!==================================== + +subroutine psb_z_base_cp_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_to_coo + +subroutine psb_z_base_cp_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_from_coo + + +subroutine psb_z_base_cp_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_to_fmt + +subroutine psb_z_base_cp_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_from_fmt + + +subroutine psb_z_base_mv_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_to_coo + +subroutine psb_z_base_mv_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_from_coo + + +subroutine psb_z_base_mv_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_to_fmt + +subroutine psb_z_base_mv_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_from_fmt + +subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_csput + +subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csgetrow + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_csgetrow + + + +subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csgetblk + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_base_csgetblk + + +subroutine psb_z_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csclip + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_base_csclip + + +subroutine psb_z_base_transp_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_z_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='z_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_z_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + class default + info = 700 + end select + if (info /= 0) then + call psb_errpush(info,name,a_err=b%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_transp_2mat + +subroutine psb_z_base_transc_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transc_2mat + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transc(b) +end subroutine psb_z_base_transc_2mat + +subroutine psb_z_base_transp_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(inout) :: a + + type(psb_z_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='z_base_transp' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + + if (info /= 0) then + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_transp_1mat + +subroutine psb_z_base_transc_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transc_1mat + implicit none + + class(psb_z_base_sparse_mat), intent(inout) :: a + + call a%transc() +end subroutine psb_z_base_transc_1mat + + +!==================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!==================================== + +subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmm + use psb_error_mod + + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_csmm + + +subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmv + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_z_base_csmv + + +subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_cssm + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_inner_cssm + + +subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_cssv + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_inner_cssv + + +subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + + complex(psb_dpk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='z_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(zone,x,zzero,tmp,info,trans) + + if (info == 0)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == 0)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_z_base_cssm + + +subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + + complex(psb_dpk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='z_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= 0) info = 4000 + if (info == 0) call inner_vscal(nac,d,x,tmp) + if (info == 0)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == zzero) then + call a%inner_cssm(alpha,x,zzero,y,info,trans) + if (info == 0) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%inner_cssm(alpha,x,zzero,tmp,info,trans) + + if (info == 0) call inner_vscal1(nar,d,tmp) + if (info == 0)& + & call psb_geaxpby(nar,zone,tmp,beta,y,info) + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + complex(psb_dpk_), intent(in) :: d(*),x(*) + complex(psb_dpk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + complex(psb_dpk_), intent(in) :: d(*) + complex(psb_dpk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_z_base_cssv + + +subroutine psb_z_base_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scals + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='z_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_scals + + + +subroutine psb_z_base_scal(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scal + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='z_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_scal + + + +function psb_z_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csnmi + + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_z_base_csnmi + +subroutine psb_z_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_get_diag + + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_get_diag + + + + diff --git a/base/serial/f03/psb_z_coo_impl.f03 b/base/serial/f03/psb_z_coo_impl.f03 index a4d33485..8103e844 100644 --- a/base/serial/f03/psb_z_coo_impl.f03 +++ b/base/serial/f03/psb_z_coo_impl.f03 @@ -1,9 +1,439 @@ -subroutine z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_get_diag(a,d,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = zzero + + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_get_diag + + +subroutine psb_z_coo_scal(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_scal + + +subroutine psb_z_coo_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scals + use psb_error_mod use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_scals + + +subroutine psb_z_coo_reallocate_nz(nz,a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_z_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_reallocate_nz + + + +subroutine psb_z_coo_reinit(a,clear) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reinit + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_reinit + + + +subroutine psb_z_coo_trim(a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + nz = a%get_nzeros() + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_trim + + +subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_allocate_mnnz use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_allocate_mnnz + + + +subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_print use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_cssm_impl + implicit none + + integer, intent(in) :: iout + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_z_coo_print + + + + +function psb_z_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_nz_row + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_z_coo_get_nz_row + +subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cssm implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -17,7 +447,7 @@ subroutine z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) complex(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra Integer :: err_act - character(len=20) :: name='z_base_cssm' + character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. info = 0 @@ -44,6 +474,17 @@ subroutine z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T') ctra = (psb_toupper(trans_)=='C') m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() @@ -340,15 +781,15 @@ contains end if end subroutine inner_coosm -end subroutine z_coo_cssm_impl +end subroutine psb_z_coo_cssm -subroutine z_coo_cssv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_cssv_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cssv implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -382,7 +823,16 @@ subroutine z_coo_cssv_impl(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_)=='T') ctra = (psb_toupper(trans_)=='C') m = a%get_nrows() - + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if if (.not. (a%is_triangle())) then info = 1121 call psb_errpush(info,name) @@ -678,13 +1128,13 @@ contains end subroutine inner_coosv -end subroutine z_coo_cssv_impl +end subroutine psb_z_coo_cssv -subroutine z_coo_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_csMv_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csmv implicit none class(psb_z_coo_sparse_mat), intent(in) :: a @@ -729,6 +1179,16 @@ subroutine z_coo_csmv_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if nnz = a%get_nzeros() if (alpha == zzero) then @@ -865,14 +1325,14 @@ subroutine z_coo_csmv_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine z_coo_csmv_impl +end subroutine psb_z_coo_csmv -subroutine z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_csmm_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csmm implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -917,6 +1377,17 @@ subroutine z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) n = a%get_ncols() m = a%get_nrows() end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() nc = min(size(x,2), size(y,2)) @@ -1061,11 +1532,11 @@ subroutine z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) end if return -end subroutine z_coo_csmm_impl +end subroutine psb_z_coo_csmm -function z_coo_csnmi_impl(a) result(res) +function psb_z_coo_csnmi(a) result(res) use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_csnmi_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csnmi implicit none class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1094,7 +1565,7 @@ function z_coo_csnmi_impl(a) result(res) i = j end do -end function z_coo_csnmi_impl +end function psb_z_coo_csnmi @@ -1112,13 +1583,13 @@ end function z_coo_csnmi_impl -subroutine z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_csgetptn_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csgetptn implicit none class(psb_z_coo_sparse_mat), intent(in) :: a @@ -1183,7 +1654,7 @@ subroutine z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1383,16 +1854,16 @@ contains end subroutine coo_getptn -end subroutine z_coo_csgetptn_impl +end subroutine psb_z_coo_csgetptn -subroutine z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_csgetrow_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csgetrow implicit none class(psb_z_coo_sparse_mat), intent(in) :: a @@ -1458,7 +1929,7 @@ subroutine z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 @@ -1667,16 +2138,16 @@ contains end subroutine coo_getrow -end subroutine z_coo_csgetrow_impl +end subroutine psb_z_coo_csgetrow -subroutine z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod use psb_sort_mod - use psb_z_base_mat_mod, psb_protect_name => z_coo_csput_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csput implicit none - + class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -1691,7 +2162,7 @@ subroutine z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 0 call psb_erractionsave(err_act) - + if (nz <= 0) then info = 10 int_err(1)=1 @@ -1734,7 +2205,7 @@ subroutine z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info,gtl) call a%set_nzeros(nza) call a%set_sorted(.false.) - + else if (a%is_upd()) then @@ -2044,18 +2515,176 @@ contains end if - end subroutine z_coo_srch_upd + end subroutine z_coo_srch_upd + +end subroutine psb_z_coo_csput + + +subroutine psb_z_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_coo + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + b%ia(:) = a%ia(:) + b%ja(:) = a%ja(:) + b%val(:) = a%val(:) + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_to_coo + +subroutine psb_z_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_coo + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_from_coo + + +subroutine psb_z_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_fmt + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_to_fmt + +subroutine psb_z_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_fmt + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return -end subroutine z_coo_csput_impl +end subroutine psb_z_cp_coo_from_fmt -subroutine z_cp_coo_to_coo_impl(a,b,info) +subroutine psb_z_mv_coo_to_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_to_coo_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_to_coo implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2065,14 +2694,14 @@ subroutine z_cp_coo_to_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) - + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) - b%ia(:) = a%ia(:) - b%ja(:) = a%ja(:) - b%val(:) = a%val(:) + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() call b%fix(info) @@ -2091,15 +2720,14 @@ subroutine z_cp_coo_to_coo_impl(a,b,info) end if return -end subroutine z_cp_coo_to_coo_impl - -subroutine z_cp_coo_from_coo_impl(a,b,info) +end subroutine psb_z_mv_coo_to_coo + +subroutine psb_z_mv_coo_from_coo(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_from_coo_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_from_coo implicit none - class(psb_z_coo_sparse_mat), intent(out) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2110,14 +2738,14 @@ subroutine z_cp_coo_from_coo_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) - a%ia(:) = b%ia(:) - a%ja(:) = b%ja(:) - a%val(:) = b%val(:) - + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() call a%fix(info) if (info /= 0) goto 9999 @@ -2135,16 +2763,15 @@ subroutine z_cp_coo_from_coo_impl(a,b,info) end if return -end subroutine z_cp_coo_from_coo_impl +end subroutine psb_z_mv_coo_from_coo -subroutine z_cp_coo_to_fmt_impl(a,b,info) +subroutine psb_z_mv_coo_to_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_to_fmt_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_to_fmt implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2155,7 +2782,7 @@ subroutine z_cp_coo_to_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_from_coo(a,info) + call b%mv_from_coo(a,info) if (info /= 0) goto 9999 @@ -2172,15 +2799,14 @@ subroutine z_cp_coo_to_fmt_impl(a,b,info) end if return -end subroutine z_cp_coo_to_fmt_impl - -subroutine z_cp_coo_from_fmt_impl(a,b,info) +end subroutine psb_z_mv_coo_to_fmt + +subroutine psb_z_mv_coo_from_fmt(a,b,info) use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_from_fmt_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_from_fmt implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(in) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info Integer :: err_act @@ -2192,8 +2818,74 @@ subroutine z_cp_coo_from_fmt_impl(a,b,info) call psb_erractionsave(err_act) info = 0 - call b%cp_to_coo(a,info) + call b%mv_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_mv_coo_from_fmt + +subroutine psb_z_coo_cp_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cp_from + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + type(psb_z_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%cp_from_coo(b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_coo_cp_from + +subroutine psb_z_coo_mv_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_mv_from + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%mv_from_coo(b,info) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -2209,16 +2901,14 @@ subroutine z_cp_coo_from_fmt_impl(a,b,info) end if return -end subroutine z_cp_coo_from_fmt_impl +end subroutine psb_z_coo_mv_from + -subroutine z_fix_coo_impl(a,info,idir) +subroutine psb_z_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_string_mod - use psb_ip_reord_mod - use psb_z_base_mat_mod, psb_protect_name => z_fix_coo_impl + use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a @@ -2251,12 +2941,12 @@ subroutine z_fix_coo_impl(a,info,idir) dupl_ = a%get_dupl() - call z_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - + call psb_z_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= 0) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() - + call psb_erractionrestore(err_act) return @@ -2269,19 +2959,18 @@ subroutine z_fix_coo_impl(a,info,idir) end if return -end subroutine z_fix_coo_impl +end subroutine psb_z_fix_coo -subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_fix_coo_inner + use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo_inner use psb_string_mod use psb_ip_reord_mod implicit none - + integer, intent(in) :: nzin, dupl integer, intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) @@ -2313,7 +3002,7 @@ subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) if (nzin < 2) return dupl_ = dupl - + allocate(iaux(nzin+2),stat=info) if (info /= 0) return @@ -2490,7 +3179,7 @@ subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) end select nzout = i - + deallocate(iaux) call psb_erractionrestore(err_act) @@ -2506,169 +3195,5 @@ subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) -end subroutine z_fix_coo_inner - - - - -subroutine z_mv_coo_to_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_to_coo_impl - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) - call b%set_nzeros(a%get_nzeros()) - call b%reallocate(a%get_nzeros()) - - call move_alloc(a%ia, b%ia) - call move_alloc(a%ja, b%ja) - call move_alloc(a%val, b%val) - call a%free() - - call b%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine z_mv_coo_to_coo_impl - -subroutine z_mv_coo_from_coo_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_from_coo_impl - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) - call a%set_nzeros(b%get_nzeros()) - call a%reallocate(b%get_nzeros()) - - call move_alloc(b%ia , a%ia ) - call move_alloc(b%ja , a%ja ) - call move_alloc(b%val, a%val ) - call b%free() - call a%fix(info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine z_mv_coo_from_coo_impl - - -subroutine z_mv_coo_to_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_to_fmt_impl - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='to_coo' - logical, parameter :: debug=.false. - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_from_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine z_mv_coo_to_fmt_impl - -subroutine z_mv_coo_from_fmt_impl(a,b,info) - use psb_error_mod - use psb_realloc_mod - use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_from_fmt_impl - implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info - - Integer :: err_act - character(len=20) :: name='from_coo' - logical, parameter :: debug=.false. - integer :: m,n,nz - - - call psb_erractionsave(err_act) - info = 0 - - call b%mv_to_coo(a,info) - - if (info /= 0) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return +end subroutine psb_z_fix_coo_inner -end subroutine z_mv_coo_from_fmt_impl diff --git a/base/serial/f03/psb_z_csc_impl.f03 b/base/serial/f03/psb_z_csc_impl.f03 index 704b4b91..02a26030 100644 --- a/base/serial/f03/psb_z_csc_impl.f03 +++ b/base/serial/f03/psb_z_csc_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine z_csc_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_z_csc_mat_mod, psb_protect_name => z_csc_csmv_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csmv implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -60,6 +60,19 @@ subroutine z_csc_csmv_impl(alpha,a,x,beta,y,info,trans) end if + if (size(x,1) z_csc_csmm_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csmm implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -460,6 +473,19 @@ subroutine z_csc_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) z_csc_cssv_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cssv implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -869,6 +895,19 @@ subroutine z_csc_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x,1) z_csc_cssm_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cssm implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1114,6 +1157,19 @@ subroutine z_csc_cssm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() nc = min(size(x,2) , size(y,2)) + if (size(x,1) z_csc_csnmi_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csnmi implicit none class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1348,7 +1404,7 @@ function z_csc_csnmi_impl(a) result(res) logical, parameter :: debug=.false. - res = dzero + res = zzero nr = a%get_nrows() nc = a%get_ncols() allocate(acc(nr),stat=info) @@ -1366,7 +1422,135 @@ function z_csc_csnmi_impl(a) result(res) end do deallocate(acc) -end function z_csc_csnmi_impl +end function psb_z_csc_csnmi + + +subroutine psb_z_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_get_diag + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = zzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_get_diag + + +subroutine psb_z_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scal + implicit none + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_scal + + +subroutine psb_z_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scals + implicit none + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_scals + !===================================== ! @@ -1380,14 +1564,14 @@ end function z_csc_csnmi_impl ! !===================================== -subroutine z_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_csc_csgetptn_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetptn implicit none class(psb_z_csc_sparse_mat), intent(in) :: a @@ -1563,19 +1747,19 @@ contains end subroutine csc_getptn -end subroutine z_csc_csgetptn_impl +end subroutine psb_z_csc_csgetptn -subroutine z_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_csc_csgetrow_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetrow implicit none class(psb_z_csc_sparse_mat), intent(in) :: a @@ -1758,14 +1942,14 @@ contains end if end subroutine csc_getrow -end subroutine z_csc_csgetrow_impl +end subroutine psb_z_csc_csgetrow -subroutine z_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) +subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_z_csc_mat_mod, psb_protect_name => z_csc_csput_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -1780,7 +1964,37 @@ subroutine z_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1788,9 +2002,9 @@ subroutine z_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call z_csc_srch_upd(nz,ia,ja,val,a,& + call psb_z_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1820,7 +2034,7 @@ subroutine z_csc_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine z_csc_srch_upd(nz,ia,ja,val,a,& + subroutine psb_z_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -2018,17 +2232,17 @@ contains end if - end subroutine z_csc_srch_upd + end subroutine psb_z_csc_srch_upd -end subroutine z_csc_csput_impl +end subroutine psb_z_csc_csput -subroutine z_cp_csc_from_coo_impl(a,b,info) +subroutine psb_z_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_cp_csc_from_coo_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_from_coo implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -2049,18 +2263,18 @@ subroutine z_cp_csc_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine z_cp_csc_from_coo_impl +end subroutine psb_z_cp_csc_from_coo -subroutine z_cp_csc_to_coo_impl(a,b,info) +subroutine psb_z_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_cp_csc_to_coo_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_to_coo implicit none class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -2092,18 +2306,18 @@ subroutine z_cp_csc_to_coo_impl(a,b,info) call b%fix(info) -end subroutine z_cp_csc_to_coo_impl +end subroutine psb_z_cp_csc_to_coo -subroutine z_mv_csc_to_coo_impl(a,b,info) +subroutine psb_z_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_mv_csc_to_coo_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_to_coo implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -2134,15 +2348,15 @@ subroutine z_mv_csc_to_coo_impl(a,b,info) call a%free() call b%fix(info) -end subroutine z_mv_csc_to_coo_impl +end subroutine psb_z_mv_csc_to_coo -subroutine z_mv_csc_from_coo_impl(a,b,info) +subroutine psb_z_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_mv_csc_from_coo_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_coo implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -2225,18 +2439,18 @@ subroutine z_mv_csc_from_coo_impl(a,b,info) endif -end subroutine z_mv_csc_from_coo_impl +end subroutine psb_z_mv_csc_from_coo -subroutine z_mv_csc_to_fmt_impl(a,b,info) +subroutine psb_z_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_mv_csc_to_fmt_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_to_fmt implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2265,18 +2479,18 @@ subroutine z_mv_csc_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine z_mv_csc_to_fmt_impl +end subroutine psb_z_mv_csc_to_fmt !!$ -subroutine z_cp_csc_to_fmt_impl(a,b,info) +subroutine psb_z_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_cp_csc_to_fmt_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_to_fmt implicit none class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2300,22 +2514,19 @@ subroutine z_cp_csc_to_fmt_impl(a,b,info) b%ia = a%ia b%val = a%val -!!$ type is (psb_z_csc_sparse_mat) -!!$ b = a - class default call tmp%cp_from_fmt(a,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine z_cp_csc_to_fmt_impl +end subroutine psb_z_cp_csc_to_fmt -subroutine z_mv_csc_from_fmt_impl(a,b,info) +subroutine psb_z_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_mv_csc_from_fmt_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_fmt implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -2348,15 +2559,15 @@ subroutine z_mv_csc_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine z_mv_csc_from_fmt_impl +end subroutine psb_z_mv_csc_from_fmt -subroutine z_cp_csc_from_fmt_impl(a,b,info) +subroutine psb_z_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csc_mat_mod, psb_protect_name => z_cp_csc_from_fmt_impl + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_from_fmt implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -2387,5 +2598,403 @@ subroutine z_cp_csc_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine z_cp_csc_from_fmt_impl +end subroutine psb_z_cp_csc_from_fmt + + +subroutine psb_z_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_z_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_reallocate_nz + + + +subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetblk + implicit none + + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_csgetblk + +subroutine psb_z_csc_reinit(a,clear) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_reinit + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_reinit + +subroutine psb_z_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_trim + implicit none + class(psb_z_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + n = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_trim + +subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_z_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(n+1,a%icp,info) + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_allocate_mnnz + +subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_z_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_z_csc_print + +subroutine psb_z_csc_cp_from(a,b) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cp_from + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + type(psb_z_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csc_cp_from + +subroutine psb_z_csc_mv_from(a,b) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mv_from + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csc_mv_from + + diff --git a/base/serial/f03/psb_z_csr_impl.f03 b/base/serial/f03/psb_z_csr_impl.f03 index 1a4ee086..6f3958b5 100644 --- a/base/serial/f03/psb_z_csr_impl.f03 +++ b/base/serial/f03/psb_z_csr_impl.f03 @@ -12,10 +12,10 @@ ! !===================================== -subroutine z_csr_csmv_impl(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod - use psb_z_csr_mat_mod, psb_protect_name => z_csr_csmv_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csmv implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -58,7 +58,20 @@ subroutine z_csr_csmv_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - call z_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + if (size(x,1) z_csr_csmm_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csmm implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -389,6 +402,18 @@ subroutine z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if + if (size(x,1) z_csr_cssv_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cssv implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -725,6 +750,17 @@ subroutine z_csr_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 end if + if (size(x) z_csr_cssm_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cssm implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -953,7 +989,7 @@ subroutine z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) complex(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra Integer :: err_act - character(len=20) :: name='z_base_cssm' + character(len=20) :: name='z_csr_cssm' logical, parameter :: debug=.false. info = 0 @@ -1198,11 +1234,11 @@ contains end if end subroutine inner_csrsm -end subroutine z_csr_cssm_impl +end subroutine psb_z_csr_cssm -function z_csr_csnmi_impl(a) result(res) +function psb_z_csr_csnmi(a) result(res) use psb_error_mod - use psb_z_csr_mat_mod, psb_protect_name => z_csr_csnmi_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csnmi implicit none class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1225,7 +1261,136 @@ function z_csr_csnmi_impl(a) result(res) res = max(res,acc) end do -end function z_csr_csnmi_impl +end function psb_z_csr_csnmi + +subroutine psb_z_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_get_diag + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_get_diag + + +subroutine psb_z_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scal + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_scal + + +subroutine psb_z_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scals + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_scals + + + !===================================== ! @@ -1240,14 +1405,113 @@ end function z_csr_csnmi_impl !===================================== -subroutine z_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& +subroutine psb_z_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_z_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_reallocate_nz + + +subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_z_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_allocate_mnnz + + +subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_csr_csgetptn_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csgetptn implicit none class(psb_z_csr_sparse_mat), intent(in) :: a @@ -1358,7 +1622,7 @@ contains integer, optional :: iren(:) integer :: nzin_, nza, idx,i,j,k, nzt, irw, lrw integer :: debug_level, debug_unit - character(len=20) :: name='coo_getrow' + character(len=20) :: name='csr_getptn' debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -1412,17 +1676,17 @@ contains end subroutine csr_getptn -end subroutine z_csr_csgetptn_impl +end subroutine psb_z_csr_csgetptn -subroutine z_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& +subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_csr_csgetrow_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csgetrow implicit none class(psb_z_csr_sparse_mat), intent(in) :: a @@ -1443,7 +1707,7 @@ subroutine z_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& call psb_erractionsave(err_act) info = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1593,14 +1857,73 @@ contains end subroutine csr_getrow -end subroutine z_csr_csgetrow_impl +end subroutine psb_z_csr_csgetrow +subroutine psb_z_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csgetblk + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. -subroutine z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_csgetblk + + + +subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psb_z_csr_mat_mod, psb_protect_name => z_csr_csput_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -1615,7 +1938,38 @@ subroutine z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() if (a%is_bld()) then @@ -1623,9 +1977,9 @@ subroutine z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) info = 1121 else if (a%is_upd()) then - call z_csr_srch_upd(nz,ia,ja,val,a,& + call psb_z_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - + if (info /= 0) then info = 1121 @@ -1655,7 +2009,7 @@ subroutine z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) contains - subroutine z_csr_srch_upd(nz,ia,ja,val,a,& + subroutine psb_z_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) use psb_const_mod @@ -1848,17 +2202,181 @@ contains end if - end subroutine z_csr_srch_upd + end subroutine psb_z_csr_srch_upd + +end subroutine psb_z_csr_csput + + +subroutine psb_z_csr_reinit(a,clear) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_reinit + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_reinit + +subroutine psb_z_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_trim + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + m = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(m+1,a%irp,info) + + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_trim + +subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_csr_print' + logical, parameter :: debug=.false. -end subroutine z_csr_csput_impl + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif -subroutine z_cp_csr_from_coo_impl(a,b,info) + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_z_csr_print + + +subroutine psb_z_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_from_coo_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_coo implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -1871,7 +2389,7 @@ subroutine z_cp_csr_from_coo_impl(a,b,info) logical :: rwshr_ Integer :: nza, nr, i,j,irw, idl,err_act, nc Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit + integer :: debug_level, debug_unit character(len=20) :: name info = 0 @@ -1879,18 +2397,18 @@ subroutine z_cp_csr_from_coo_impl(a,b,info) call tmp%cp_from_coo(b,info) if (info ==0) call a%mv_from_coo(tmp,info) -end subroutine z_cp_csr_from_coo_impl +end subroutine psb_z_cp_csr_from_coo -subroutine z_cp_csr_to_coo_impl(a,b,info) +subroutine psb_z_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_to_coo_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_to_coo implicit none class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1921,18 +2439,18 @@ subroutine z_cp_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine z_cp_csr_to_coo_impl +end subroutine psb_z_cp_csr_to_coo -subroutine z_mv_csr_to_coo_impl(a,b,info) +subroutine psb_z_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_to_coo_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_to_coo implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(out) :: b + class(psb_z_coo_sparse_mat), intent(inout) :: b integer, intent(out) :: info integer, allocatable :: itemp(:) @@ -1964,15 +2482,15 @@ subroutine z_mv_csr_to_coo_impl(a,b,info) call b%fix(info) -end subroutine z_mv_csr_to_coo_impl +end subroutine psb_z_mv_csr_to_coo -subroutine z_mv_csr_from_coo_impl(a,b,info) +subroutine psb_z_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_from_coo_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_coo implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -2055,18 +2573,17 @@ subroutine z_mv_csr_from_coo_impl(a,b,info) endif -end subroutine z_mv_csr_from_coo_impl +end subroutine psb_z_mv_csr_from_coo -subroutine z_mv_csr_to_fmt_impl(a,b,info) +subroutine psb_z_mv_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_to_fmt_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_to_fmt implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2095,18 +2612,17 @@ subroutine z_mv_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine z_mv_csr_to_fmt_impl +end subroutine psb_z_mv_csr_to_fmt -subroutine z_cp_csr_to_fmt_impl(a,b,info) +subroutine psb_z_cp_csr_to_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_to_fmt_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_to_fmt implicit none class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b + class(psb_z_base_sparse_mat), intent(inout) :: b integer, intent(out) :: info !locals @@ -2135,14 +2651,13 @@ subroutine z_cp_csr_to_fmt_impl(a,b,info) if (info == 0) call b%mv_from_coo(tmp,info) end select -end subroutine z_cp_csr_to_fmt_impl +end subroutine psb_z_cp_csr_to_fmt -subroutine z_mv_csr_from_fmt_impl(a,b,info) +subroutine psb_z_mv_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_from_fmt_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_fmt implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -2175,15 +2690,14 @@ subroutine z_mv_csr_from_fmt_impl(a,b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine z_mv_csr_from_fmt_impl +end subroutine psb_z_mv_csr_from_fmt -subroutine z_cp_csr_from_fmt_impl(a,b,info) +subroutine psb_z_cp_csr_from_fmt(a,b,info) use psb_const_mod - use psb_realloc_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_from_fmt_impl + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_fmt implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -2214,5 +2728,82 @@ subroutine z_cp_csr_from_fmt_impl(a,b,info) call tmp%cp_from_fmt(b,info) if (info == 0) call a%mv_from_coo(tmp,info) end select -end subroutine z_cp_csr_from_fmt_impl +end subroutine psb_z_cp_csr_from_fmt + + +subroutine psb_z_csr_cp_from(a,b) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cp_from + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + type(psb_z_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csr_cp_from + +subroutine psb_z_csr_mv_from(a,b) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mv_from + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + type(psb_z_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csr_mv_from + diff --git a/base/serial/f03/psb_z_mat_impl.f03 b/base/serial/f03/psb_z_mat_impl.f03 new file mode 100644 index 00000000..96ba4033 --- /dev/null +++ b/base/serial/f03/psb_z_mat_impl.f03 @@ -0,0 +1,1990 @@ +!===================================== +! +! +! +! Setters +! +! +! +! +! +! +!===================================== + + +subroutine psb_z_set_nrows(m,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_nrows + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_nrows + + +subroutine psb_z_set_ncols(n,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_ncols + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_ncols + + + +subroutine psb_z_set_state(n,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_state + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_state + + + +subroutine psb_z_set_dupl(n,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_dupl + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_dupl + + +subroutine psb_z_set_null(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_null + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_null + + +subroutine psb_z_set_bld(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_bld + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_bld + + +subroutine psb_z_set_upd(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_upd + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +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 + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_asb + + +subroutine psb_z_set_sorted(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_sorted + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_sorted + + +subroutine psb_z_set_triangle(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_triangle + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_triangle + + +subroutine psb_z_set_unit(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_unit + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_lower + + +subroutine psb_z_set_upper(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_upper + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_upper + + + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine psb_z_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_z_mat_mod, psb_protect_name => psb_z_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 0 + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_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 + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_get_neigh + + + +subroutine psb_z_csall(nr,nc,a,info,nz) + use psb_z_mat_mod, psb_protect_name => psb_z_csall + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + allocate(psb_z_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csall + + +subroutine psb_z_reallocate_nz(nz,a) + use psb_z_mat_mod, psb_protect_name => psb_z_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_reallocate_nz + + +subroutine psb_z_free(a) + use psb_z_mat_mod, psb_protect_name => psb_z_free + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%free() + deallocate(a%a) + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_free + + +subroutine psb_z_trim(a) + use psb_z_mat_mod, psb_protect_name => psb_z_trim + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_trim + + + +subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_mat_mod, psb_protect_name => psb_z_csput + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csput + + +subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csgetptn + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csgetptn + + +subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csgetrow + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +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 + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csgetblk + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + + if (info == 0) call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csgetblk + + + + +subroutine psb_z_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csclip + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csclip + + +subroutine psb_z_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_b_csclip + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_b_csclip + + + + +subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cscnv + implicit none + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + + class(psb_z_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_cscnv + + + +subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_ip + implicit none + + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + + class(psb_z_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + 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 = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=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 = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_cscnv_ip + + + +subroutine psb_z_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_base + implicit none + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_z_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == 0).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == 0) call altmp%trim() + if (info == 0) call altmp%set_asb() + if (info == 0) call b%mv_from_coo(altmp,info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_cscnv_base + + + +subroutine psb_z_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_clip_d + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%cp_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call b%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_clip_d + + + +subroutine psb_z_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_clip_d_ip + implicit none + + class(psb_z_sparse_mat), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%mv_to_coo(acoo,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + nz = acoo%get_nzeros() + j = 0 + do i=1, nz + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 + acoo%ia(j) = acoo%ia(i) + acoo%ja(j) = acoo%ja(i) + acoo%val(j) = acoo%val(i) + end if + end do + call acoo%set_nzeros(j) + call acoo%trim() + call a%mv_from(acoo) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_clip_d_ip + + +subroutine psb_z_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_from + implicit none + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer :: info + + allocate(a%a,source=b, stat=info) + call a%a%mv_from_fmt(b,info) + + return +end subroutine psb_z_mv_from + + +subroutine psb_z_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_from + implicit none + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(a%a,source=b,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call a%a%cp_from_fmt(b, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_z_cp_from + + +subroutine psb_z_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_to + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_z_mv_to + + +subroutine psb_z_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_to + implicit none + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_z_cp_to + + + +subroutine psb_z_sparse_mat_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_sparse_mat_move + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = 0 + call move_alloc(a%a,b%a) + + return +end subroutine psb_z_sparse_mat_move + + +subroutine psb_z_sparse_mat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_sparse_mat_clone + implicit none + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(b%a,source=a%a,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call b%a%cp_from_fmt(a%a, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_sparse_mat_clone + + + +subroutine psb_z_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transp_1mat + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transp_1mat + + + +subroutine psb_z_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transp_2mat + implicit none + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transp_2mat + + +subroutine psb_z_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transc_1mat + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transc_1mat + + + +subroutine psb_z_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transc_2mat + implicit none + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transc_2mat + + + + +subroutine psb_z_reinit(a,clear) + use psb_z_mat_mod, psb_protect_name => psb_z_reinit + use psb_error_mod + implicit none + + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_reinit + + + + +!===================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!===================================== + + +subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csmm + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csmm + + +subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csmv + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csmv + + +subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cssm + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_cssm + + +subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cssv + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_cssv + + + +function psb_z_csnmi(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_z_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_z_csnmi + + +subroutine psb_z_get_diag(a,d,info) + use psb_z_mat_mod, psb_protect_name => psb_z_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_get_diag + + +subroutine psb_z_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_scal + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_scal + + +subroutine psb_z_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_scals + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_scals + + + diff --git a/base/serial/psb_sort_impl.f90 b/base/serial/psb_sort_impl.f90 new file mode 100644 index 00000000..4d5b5842 --- /dev/null +++ b/base/serial/psb_sort_impl.f90 @@ -0,0 +1,4586 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! The merge-sort and quicksort routines are implemented in the +! serial/aux directory +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! + +logical function psb_isaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_isaperm + implicit none + + integer, intent(in) :: n + integer, intent(in) :: eip(n) + integer, allocatable :: ip(:) + integer i,j,m, info + + + psb_isaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= 0) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(0,*) 'Out of bounds in isaperm' ,ip(i), n + psb_isaperm = .false. + return + endif + enddo + + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = iabs(ip(m)) + if (j /= m) then + psb_isaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue + + return +end function psb_isaperm + +function psb_ibsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_ibsrch + implicit none + integer ipos, key, n + integer v(n) + + integer lb, ub, m + + lb = 1 + ub = n + ipos = -1 + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + return +end function psb_ibsrch + +function psb_issrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_issrch + implicit none + integer ipos, key, n + integer v(n) + + integer i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + return +end function psb_issrch + + +subroutine imsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => imsort + use psb_error_mod + implicit none + integer, intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + call imsrx(n,x,ix,dir_,flag_) + else + call imsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine imsort + + +subroutine smsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => smsort + use psb_error_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + call smsrx(n,x,ix,dir_,flag_) + else + call smsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine smsort + +subroutine dmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => dmsort + use psb_error_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + call dmsrx(n,x,ix,dir_,flag_) + else + call dmsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine dmsort + +subroutine camsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => camsort + use psb_error_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + select case(dir_) + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + call camsrx(n,x,ix,dir_,flag_) + else + call camsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine camsort + +subroutine zamsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => zamsort + use psb_error_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + select case(dir_) + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + call zamsrx(n,x,ix,dir_,flag_) + else + call zamsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine zamsort + + +subroutine imsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => imsort_u + use psb_error_mod + implicit none + integer, intent(inout) :: x(:) + integer, intent(out) :: nout + integer, optional, intent(in) :: dir + + integer :: dir_, n, err_act + + character(len=20) :: name + + name='psb_msort_u' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + call imsru(n,x,dir_,nout) + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine imsort_u + + +subroutine iqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => iqsort + use psb_error_mod + implicit none + integer, intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call isrx(n,x,ix,dir_,flag_) + else + call isr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call iasrx(n,x,ix,dir_,flag_) + else + call iasr(n,x,dir_) + end if + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine iqsort + + +subroutine sqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => sqsort + use psb_error_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call ssrx(n,x,ix,dir_,flag_) + else + call ssr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call sasrx(n,x,ix,dir_,flag_) + else + call sasr(n,x,dir_) + end if + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine sqsort + +subroutine dqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => dqsort + use psb_error_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call dsrx(n,x,ix,dir_,flag_) + else + call dsr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call dasrx(n,x,ix,dir_,flag_) + else + call dasr(n,x,dir_) + end if + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine dqsort + + +subroutine cqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => cqsort + use psb_error_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_lsort_up_ + end if + + n = size(x) + + select case(dir_) + case( psb_lsort_up_, psb_lsort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call clsrx(n,x,ix,dir_,flag_) + else + call clsr(n,x,dir_) + end if + + case( psb_alsort_up_, psb_alsort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call calsrx(n,x,ix,dir_,flag_) + else + call calsr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call casrx(n,x,ix,dir_,flag_) + else + call casr(n,x,dir_) + end if + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine cqsort + + +subroutine zqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => zqsort + use psb_error_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_lsort_up_ + end if + + n = size(x) + + select case(dir_) + case( psb_lsort_up_, psb_lsort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call zlsrx(n,x,ix,dir_,flag_) + else + call zlsr(n,x,dir_) + end if + + case( psb_alsort_up_, psb_alsort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call zalsrx(n,x,ix,dir_,flag_) + else + call zalsr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call zasrx(n,x,ix,dir_,flag_) + else + call zasr(n,x,dir_) + end if + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine zqsort + + + + +subroutine ihsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => ihsort + use psb_error_mod + implicit none + integer, intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + integer :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_int_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_int_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_int_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_int_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine ihsort + + +subroutine shsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => shsort + use psb_error_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + real(psb_spk_) :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_real_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_real_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_real_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_real_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine shsort + + +subroutine dhsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => dhsort + use psb_error_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + real(psb_dpk_) :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_double_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_double_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_double_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_double_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine dhsort + + +subroutine chsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => chsort + use psb_error_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + complex(psb_spk_) :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + + select case(dir_) + case(psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_scomplex_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_scomplex_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_scomplex_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_scomplex_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine chsort + + +subroutine zhsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => zhsort + use psb_error_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + complex(psb_dpk_) :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + + select case(dir_) + case(psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_dcomplex_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_dcomplex_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_dcomplex_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_dcomplex_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine zhsort + + +function psb_howmany_int_heap(heap) + use psb_sort_mod, psb_protect_name => psb_howmany_int_heap + implicit none + type(psb_int_heap), intent(in) :: heap + integer :: psb_howmany_int_heap + psb_howmany_int_heap = heap%last +end function psb_howmany_int_heap + +subroutine psb_init_int_heap(heap,info,dir) + use psb_sort_mod, psb_protect_name => psb_init_int_heap + use psb_realloc_mod + implicit none + type(psb_int_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + return +end subroutine psb_init_int_heap + +subroutine psb_dump_int_heap(iout,heap,info) + use psb_sort_mod, psb_protect_name => psb_dump_int_heap + implicit none + type(psb_int_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0) then + write(iout,*) heap%keys(1:heap%last) + end if + end if +end subroutine psb_dump_int_heap + +subroutine psb_insert_int_heap(key,heap,info) + use psb_sort_mod, psb_protect_name => psb_insert_int_heap + use psb_realloc_mod + implicit none + + integer, intent(in) :: key + type(psb_int_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + heap%last = heap%last + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_int_heap(key,heap%last,heap%keys,heap%dir,info) + + return +end subroutine psb_insert_int_heap + + +subroutine psb_int_heap_get_first(key,heap,info) + use psb_sort_mod, psb_protect_name => psb_int_heap_get_first + implicit none + + type(psb_int_heap), intent(inout) :: heap + integer, intent(out) :: key,info + + info = 0 + + call psi_int_heap_get_first(key,heap%last,heap%keys,heap%dir,info) + + return +end subroutine psb_int_heap_get_first + + +function psb_howmany_real_idx_heap(heap) + use psb_sort_mod, psb_protect_name => psb_howmany_real_idx_heap + implicit none + type(psb_real_idx_heap), intent(in) :: heap + integer :: psb_howmany_real_idx_heap + psb_howmany_real_idx_heap = heap%last +end function psb_howmany_real_idx_heap + +subroutine psb_init_real_idx_heap(heap,info,dir) + use psb_sort_mod, psb_protect_name => psb_init_real_idx_heap + use psb_realloc_mod + implicit none + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return +end subroutine psb_init_real_idx_heap + +subroutine psb_dump_real_idx_heap(iout,heap,info) + use psb_sort_mod, psb_protect_name => psb_dump_real_idx_heap + implicit none + type(psb_real_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if +end subroutine psb_dump_real_idx_heap + +subroutine psb_insert_real_idx_heap(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_insert_real_idx_heap + use psb_realloc_mod + implicit none + + real(psb_spk_), intent(in) :: key + integer, intent(in) :: index + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + + call psi_insert_real_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_insert_real_idx_heap + +subroutine psb_real_idx_heap_get_first(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_real_idx_heap_get_first + implicit none + + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + real(psb_spk_), intent(out) :: key + + info = 0 + + call psi_real_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_real_idx_heap_get_first + + +function psb_howmany_double_idx_heap(heap) + use psb_sort_mod, psb_protect_name => psb_howmany_double_idx_heap + implicit none + type(psb_double_idx_heap), intent(in) :: heap + integer :: psb_howmany_double_idx_heap + psb_howmany_double_idx_heap = heap%last +end function psb_howmany_double_idx_heap + +subroutine psb_init_double_idx_heap(heap,info,dir) + use psb_sort_mod, psb_protect_name => psb_init_double_idx_heap + use psb_realloc_mod + implicit none + type(psb_double_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return +end subroutine psb_init_double_idx_heap + +subroutine psb_dump_double_idx_heap(iout,heap,info) + use psb_sort_mod, psb_protect_name => psb_dump_double_idx_heap + implicit none + type(psb_double_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if +end subroutine psb_dump_double_idx_heap + +subroutine psb_insert_double_idx_heap(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_insert_double_idx_heap + use psb_realloc_mod + implicit none + + real(psb_dpk_), intent(in) :: key + integer, intent(in) :: index + type(psb_double_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + + call psi_insert_double_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_insert_double_idx_heap + +subroutine psb_double_idx_heap_get_first(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_double_idx_heap_get_first + implicit none + + type(psb_double_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + real(psb_dpk_), intent(out) :: key + + info = 0 + + call psi_double_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_double_idx_heap_get_first + +function psb_howmany_int_idx_heap(heap) + use psb_sort_mod, psb_protect_name => psb_howmany_int_idx_heap + implicit none + type(psb_int_idx_heap), intent(in) :: heap + integer :: psb_howmany_int_idx_heap + psb_howmany_int_idx_heap = heap%last +end function psb_howmany_int_idx_heap + +subroutine psb_init_int_idx_heap(heap,info,dir) + use psb_sort_mod, psb_protect_name => psb_init_int_idx_heap + use psb_realloc_mod + implicit none + type(psb_int_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return +end subroutine psb_init_int_idx_heap + +subroutine psb_dump_int_idx_heap(iout,heap,info) + use psb_sort_mod, psb_protect_name => psb_dump_int_idx_heap + implicit none + type(psb_int_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if +end subroutine psb_dump_int_idx_heap + +subroutine psb_insert_int_idx_heap(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_insert_int_idx_heap + use psb_realloc_mod + implicit none + + integer, intent(in) :: key + integer, intent(in) :: index + type(psb_int_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + + call psi_insert_int_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_insert_int_idx_heap + +subroutine psb_int_idx_heap_get_first(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_int_idx_heap_get_first + implicit none + + type(psb_int_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + integer, intent(out) :: key + + info = 0 + + call psi_int_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_int_idx_heap_get_first + + + +function psb_howmany_scomplex_idx_heap(heap) + use psb_sort_mod, psb_protect_name => psb_howmany_scomplex_idx_heap + implicit none + type(psb_scomplex_idx_heap), intent(in) :: heap + integer :: psb_howmany_scomplex_idx_heap + psb_howmany_scomplex_idx_heap = heap%last +end function psb_howmany_scomplex_idx_heap + +subroutine psb_init_scomplex_idx_heap(heap,info,dir) + use psb_sort_mod, psb_protect_name => psb_init_scomplex_idx_heap + use psb_realloc_mod + implicit none + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) +!!$ case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + case (psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_asort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return +end subroutine psb_init_scomplex_idx_heap + +subroutine psb_dump_scomplex_idx_heap(iout,heap,info) + use psb_sort_mod, psb_protect_name => psb_dump_scomplex_idx_heap + implicit none + type(psb_scomplex_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if +end subroutine psb_dump_scomplex_idx_heap + +subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_insert_scomplex_idx_heap + use psb_realloc_mod + implicit none + + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: index + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_scomplex_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_insert_scomplex_idx_heap + +subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_scomplex_idx_heap_get_first + implicit none + + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + complex(psb_spk_), intent(out) :: key + + + info = 0 + + call psi_scomplex_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_scomplex_idx_heap_get_first + + + +function psb_howmany_dcomplex_idx_heap(heap) + use psb_sort_mod, psb_protect_name => psb_howmany_dcomplex_idx_heap + implicit none + type(psb_dcomplex_idx_heap), intent(in) :: heap + integer :: psb_howmany_dcomplex_idx_heap + psb_howmany_dcomplex_idx_heap = heap%last +end function psb_howmany_dcomplex_idx_heap + +subroutine psb_init_dcomplex_idx_heap(heap,info,dir) + use psb_sort_mod, psb_protect_name => psb_init_dcomplex_idx_heap + use psb_realloc_mod + implicit none + type(psb_dcomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) +!!$ case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + case (psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_asort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return +end subroutine psb_init_dcomplex_idx_heap + +subroutine psb_dump_dcomplex_idx_heap(iout,heap,info) + use psb_sort_mod, psb_protect_name => psb_dump_dcomplex_idx_heap + implicit none + type(psb_dcomplex_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if +end subroutine psb_dump_dcomplex_idx_heap + +subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_insert_dcomplex_idx_heap + use psb_realloc_mod + implicit none + + complex(psb_dpk_), intent(in) :: key + integer, intent(in) :: index + type(psb_dcomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_dcomplex_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_insert_dcomplex_idx_heap + +subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info) + use psb_sort_mod, psb_protect_name => psb_dcomplex_idx_heap_get_first + implicit none + + type(psb_dcomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + complex(psb_dpk_), intent(out) :: key + + + info = 0 + + call psi_dcomplex_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return +end subroutine psb_dcomplex_idx_heap_get_first + + + +! +! These are packaged so that they can be used to implement +! a heapsort, should the need arise +! + + +subroutine psi_insert_int_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_int_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer, intent(in) :: key,dir + integer, intent(inout) :: heap(:),last + integer, intent(out) :: info + integer :: i, i2 + integer :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_int_heap + + +subroutine psi_int_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_int_heap_get_first + implicit none + + integer, intent(inout) :: key,last + integer, intent(in) :: dir + integer, intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + integer :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_int_heap_get_first + + + +subroutine psi_insert_real_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_real_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_spk_), intent(in) :: key + integer, intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + real(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_real_heap + + +subroutine psi_real_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_real_heap_get_first + implicit none + + real(psb_spk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + real(psb_spk_) :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_real_heap_get_first + + +subroutine psi_insert_double_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_double_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_dpk_), intent(in) :: key + integer, intent(in) :: dir + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + real(psb_dpk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_double_heap + + +subroutine psi_double_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_double_heap_get_first + implicit none + + real(psb_dpk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + real(psb_dpk_) :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_double_heap_get_first + + + + +subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_scomplex_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + complex(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) < heap(i2)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) > heap(i2)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_scomplex_heap + + +subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_scomplex_heap_get_first + implicit none + + complex(psb_spk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + complex(psb_spk_) :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) > heap(j)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) < heap(j)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_scomplex_heap_get_first + + +subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_dcomplex_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_dpk_), intent(in) :: key + integer, intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + complex(psb_dpk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) < heap(i2)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) > heap(i2)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_dcomplex_heap + + +subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_dcomplex_heap_get_first + implicit none + + complex(psb_dpk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + complex(psb_dpk_) :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) > heap(j)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) < heap(j)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_dcomplex_heap_get_first + + + + +subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_int_idx_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + integer, intent(in) :: key + integer, intent(in) :: index,dir + integer, intent(inout) :: heap(:),last + integer, intent(inout) :: idxs(:) + integer, intent(out) :: info + integer :: i, i2, itemp + integer :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_int_idx_heap + +subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_int_idx_heap_get_first + implicit none + + integer, intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + integer, intent(out) :: key + + integer :: i, j,itemp + integer :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_int_idx_heap_get_first + +subroutine psi_insert_real_idx_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_real_idx_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + real(psb_spk_), intent(in) :: key + integer, intent(in) :: index,dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + integer :: i, i2, itemp + real(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_real_idx_heap + +subroutine psi_real_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_real_idx_heap_get_first + implicit none + + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + real(psb_spk_), intent(out) :: key + + integer :: i, j,itemp + real(psb_spk_) :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_real_idx_heap_get_first + + +subroutine psi_insert_double_idx_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_double_idx_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + real(psb_dpk_), intent(in) :: key + integer, intent(in) :: index,dir + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + integer :: i, i2, itemp + real(psb_dpk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_double_idx_heap + +subroutine psi_double_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_double_idx_heap_get_first + implicit none + + real(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + real(psb_dpk_), intent(out) :: key + + integer :: i, j,itemp + real(psb_dpk_) :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_double_idx_heap_get_first + + +subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_scomplex_idx_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: index,dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + integer :: i, i2, itemp + complex(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) < heap(i2)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(i2) +!!$ idxs(i2) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) > heap(i2)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(i2) +!!$ idxs(i2) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_scomplex_idx_heap + +subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_scomplex_idx_heap_get_first + implicit none + + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + complex(psb_spk_), intent(out) :: key + + integer :: i, j, itemp + complex(psb_spk_) :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) > heap(j)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(j) +!!$ idxs(j) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) < heap(j)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(j) +!!$ idxs(j) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_scomplex_idx_heap_get_first + + +subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_insert_dcomplex_idx_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + complex(psb_dpk_), intent(in) :: key + integer, intent(in) :: index,dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + integer :: i, i2, itemp + complex(psb_dpk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) < heap(i2)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(i2) +!!$ idxs(i2) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) > heap(i2)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(i2) +!!$ idxs(i2) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_insert_dcomplex_idx_heap + +subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_dcomplex_idx_heap_get_first + implicit none + + complex(psb_dpk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + complex(psb_dpk_), intent(out) :: key + + integer :: i, j, itemp + complex(psb_dpk_) :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) > heap(j)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(j) +!!$ idxs(j) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) < heap(j)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(j) +!!$ idxs(j) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_dcomplex_idx_heap_get_first + + + diff --git a/base/serial/psi_impl.f90 b/base/serial/psi_impl.f90 new file mode 100644 index 00000000..76d6d13b --- /dev/null +++ b/base/serial/psi_impl.f90 @@ -0,0 +1,2303 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + + subroutine psi_renum_index(iperm,idx,info) + use psi_mod, psi_protect_name => psi_renum_index + use psb_serial_mod + implicit none + + integer, intent(out) :: info + integer, intent(in) :: iperm(:) + integer, intent(inout) :: idx(:) + + integer :: i,j,k,nh + + i=1 + k=idx(i) + do while (k /= -1) + i = i+1 + nh = idx(i) + do j = i+1, i+nh + idx(j) = iperm(idx(j)) + enddo + i = i + nh + 1 + nh = idx(i) + do j = i+1, i+nh + idx(j) = iperm(idx(j)) + enddo + i = i + nh + 1 + k = idx(i) + enddo + + end subroutine psi_renum_index + + subroutine psi_renum_idxmap(nc,iperm,idxmap,info) + use psi_mod, psi_protect_name => psi_renum_idxmap + use psb_serial_mod + implicit none + + integer, intent(out) :: info + integer, intent(in) :: nc,iperm(:) + type(psb_idxmap_type), intent(inout) :: idxmap + + integer, allocatable :: itmp(:) + integer :: i,j,k,nh + + if (nc > size(iperm)) then + info = 2 + return + endif + + if (idxmap%state == psb_desc_large_) then + + allocate(itmp(size(idxmap%loc_to_glob)), stat=i) + if (i/=0) then + info = 4001 + return + end if + do i=1,nc + itmp(i) = idxmap%loc_to_glob(iperm(i)) + end do + do i=1, size(idxmap%glb_lc,1) + idxmap%glb_lc(i,2) = iperm(idxmap%glb_lc(i,2)) + end do + do i=1, nc + idxmap%loc_to_glob(i) = itmp(i) + end do + + else + + do i=1, nc + idxmap%glob_to_loc(idxmap%loc_to_glob(iperm(i))) = i + enddo + do i=1,size(idxmap%glob_to_loc) + j = idxmap%glob_to_loc(i) + if (j>0) then + idxmap%loc_to_glob(j) = i + endif + enddo + end if + + end subroutine psi_renum_idxmap + + subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) + + use psi_mod, psi_protect_name => psi_cnv_dsc + use psb_realloc_mod + implicit none + + ! ....scalars parameters.... + integer, intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) + type(psb_desc_type), intent(inout) :: cdesc + integer, intent(out) :: info + + ! ....local scalars.... + integer :: np,me + integer :: ictxt, err_act,nxch,nsnd,nrcv,j,k + ! ...local array... + integer, allocatable :: idx_out(:), tmp_mst_idx(:) + + ! ...parameters + integer :: debug_level, debug_unit + logical, parameter :: debug=.false. + character(len=20) :: name + + name='psi_bld_cdesc' + call psb_get_erraction(err_act) + debug_level = psb_get_debug_level() + debug_unit = psb_get_debug_unit() + + info = 0 + ictxt = cdesc%matrix_data(psb_ctxt_) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + ! first the halo index + if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',& + & size(halo_in) + call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 + end if + call psb_move_alloc(idx_out,cdesc%halo_index,info) + cdesc%matrix_data(psb_thal_xch_) = nxch + cdesc%matrix_data(psb_thal_snd_) = nsnd + cdesc%matrix_data(psb_thal_rcv_) = nrcv + + if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo' + if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' + + + ! then ext index + if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' + call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 + end if + call psb_move_alloc(idx_out,cdesc%ext_index,info) + cdesc%matrix_data(psb_text_xch_) = nxch + cdesc%matrix_data(psb_text_snd_) = nsnd + cdesc%matrix_data(psb_text_rcv_) = nrcv + + if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext' + if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap' + + ! then the overlap index + call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 + end if + call psb_move_alloc(idx_out,cdesc%ovrlap_index,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_move_alloc') + goto 9999 + end if + + cdesc%matrix_data(psb_tovr_xch_) = nxch + cdesc%matrix_data(psb_tovr_snd_) = nsnd + cdesc%matrix_data(psb_tovr_rcv_) = nrcv + + ! next ovrlap_elem + if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem' + call psi_crea_ovr_elem(me,cdesc%ovrlap_index,cdesc%ovrlap_elem,info) + if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem' + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_ovr_elem') + goto 9999 + end if + ! Extract ovr_mst_idx from ovrlap_elem + if (debug_level>0) write(debug_unit,*) me,'Calling bld_ovr_mst' + call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info) + if (info == 0) call psi_crea_index(cdesc,& + & tmp_mst_idx,idx_out,.false.,nxch,nsnd,nrcv,info) + if (debug_level>0) write(debug_unit,*) me,'Done crea_indx' + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_bld_ovr_mst') + goto 9999 + end if + call psb_move_alloc(idx_out,cdesc%ovr_mst_idx,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_move_alloc') + goto 9999 + end if + + cdesc%matrix_data(psb_tmov_xch_) = nxch + cdesc%matrix_data(psb_tmov_snd_) = nsnd + cdesc%matrix_data(psb_tmov_rcv_) = nrcv + + ! finally bnd_elem + call psi_crea_bnd_elem(idx_out,cdesc,info) + if (info == 0) call psb_move_alloc(idx_out,cdesc%bnd_elem,info) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') + goto 9999 + end if + if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + + end subroutine psi_cnv_dsc + + + subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) + use psi_mod, psi_protect_name => psi_inner_cnvs + + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(inout) :: x + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + + key = x + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x = glb_lc(tmp,2) + else + x = tmp + end if + end subroutine psi_inner_cnvs + + subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) + use psi_mod, psi_protect_name => psi_inner_cnvs2 + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(in) :: x + integer, intent(out) :: y + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + + key = x + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + y = glb_lc(tmp,2) + else + y = tmp + end if + end subroutine psi_inner_cnvs2 + + + subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) + use psi_mod, psi_protect_name => psi_inner_cnv1 + integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer, intent(inout) :: x(:) + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + if (present(mask)) then + do i=1, n + if (mask(i)) then + key = x(i) + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x(i) = glb_lc(tmp,2) + else + x(i) = tmp + end if + end if + end do + else + do i=1, n + key = x(i) + ih = iand(key,hashmask) + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + x(i) = glb_lc(tmp,2) + else + x(i) = tmp + end if + end do + end if + end subroutine psi_inner_cnv1 + + subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) + use psi_mod, psi_protect_name => psi_inner_cnv2 + integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in),optional :: mask(:) + integer, intent(in) :: x(:) + integer, intent(out) :: y(:) + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + if (present(mask)) then + do i=1, n + if (mask(i)) then + key = x(i) + ih = iand(key,hashmask) + if (ih > ubound(hashv,1) ) then + write(0,*) ' In inner cnv: ',ih,ubound(hashv) + end if + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + y(i) = glb_lc(tmp,2) + else + y(i) = tmp + end if + end if + end do + else + do i=1, n + key = x(i) + ih = iand(key,hashmask) + if (ih > ubound(hashv,1) ) then + write(0,*) ' In inner cnv: ',ih,ubound(hashv) + end if + idx = hashv(ih) + nh = hashv(ih+1) - hashv(ih) + if (nh > 0) then + tmp = -1 + lb = idx + ub = idx+nh-1 + do + if (lb>ub) exit + lm = (lb+ub)/2 + if (key==glb_lc(lm,1)) then + tmp = lm + exit + else if (key 0) then + y(i) = glb_lc(tmp,2) + else + y(i) = tmp + end if + end do + end if + end subroutine psi_inner_cnv2 + + subroutine psi_sovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_updr1 + + implicit none + + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_sovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_sovrl_updr1 + + + subroutine psi_sovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_updr2 + + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_sovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_sovrl_updr2 + + subroutine psi_dovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_updr1 + + implicit none + + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_dovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_updr1 + + + subroutine psi_dovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_updr2 + + implicit none + + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_dovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_updr2 + + subroutine psi_covrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_updr1 + + implicit none + + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_covrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_covrl_updr1 + + + subroutine psi_covrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_updr2 + + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_covrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_covrl_updr2 + + subroutine psi_zovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_updr1 + + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_zovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_updr1 + + + subroutine psi_zovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_updr2 + + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_zovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_updr2 + + subroutine psi_iovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_updr1 + + implicit none + + integer, intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_iovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + ! Square root does not make sense here +!!$ case(psb_square_root_) +!!$ do i=1,size(desc_a%ovrlap_elem,1) +!!$ idx = desc_a%ovrlap_elem(i,1) +!!$ ndm = desc_a%ovrlap_elem(i,2) +!!$ x(idx) = x(idx)/sqrt(real(ndm)) +!!$ end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = izero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_updr1 + + + subroutine psi_iovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_updr2 + + implicit none + + integer, intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_iovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + ! Square root does not make sense here +!!$ case(psb_square_root_) +!!$ do i=1,size(desc_a%ovrlap_elem,1) +!!$ idx = desc_a%ovrlap_elem(i,1) +!!$ ndm = desc_a%ovrlap_elem(i,2) +!!$ x(idx,:) = x(idx,:)/sqrt(real(ndm)) +!!$ end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = izero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_updr2 + + + subroutine psi_sovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_saver1 + use psb_realloc_mod + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_sovrl_saver1 + + subroutine psi_sovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restrr1 + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_sovrl_restrr1 + + + subroutine psi_sovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_saver2 + use psb_realloc_mod + + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_sovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_sovrl_saver2 + + subroutine psi_sovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restrr2 + + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_sovrl_restrr2 + + + subroutine psi_dovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_saver1 + use psb_realloc_mod + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_saver1 + + subroutine psi_dovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restrr1 + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_restrr1 + + + subroutine psi_dovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_saver2 + use psb_realloc_mod + + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_saver2 + + subroutine psi_dovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restrr2 + + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_dovrl_restrr2 + + subroutine psi_covrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_saver1 + use psb_realloc_mod + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_covrl_saver1 + + subroutine psi_covrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restrr1 + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_covrl_restrr1 + + + subroutine psi_covrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_saver2 + use psb_realloc_mod + + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_covrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_covrl_saver2 + + subroutine psi_covrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restrr2 + + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_covrl_restrr2 + + + subroutine psi_zovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_saver1 + + use psb_realloc_mod + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_saver1 + + subroutine psi_zovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restrr1 + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_restrr1 + + + subroutine psi_zovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_saver2 + + use psb_realloc_mod + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_zovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_saver2 + + subroutine psi_zovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restrr2 + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_zovrl_restrr2 + + + subroutine psi_iovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_saver1 + + use psb_realloc_mod + + implicit none + + integer, intent(inout) :: x(:) + integer, allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_saver1 + + subroutine psi_iovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restrr1 + + implicit none + + integer, intent(inout) :: x(:) + integer :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_restrr1 + + + subroutine psi_iovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_saver2 + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + integer, intent(inout) :: x(:,:) + integer, allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_iovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_saver2 + + subroutine psi_iovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restrr2 + + implicit none + + integer, intent(inout) :: x(:,:) + integer :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + end subroutine psi_iovrl_restrr2 + + subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) + use psi_mod, psi_protect_name => psi_bld_ovr_mst + + use psb_realloc_mod + implicit none + + ! ....scalars parameters.... + integer, intent(in) :: me, ovrlap_elem(:,:) + integer, allocatable, intent(out) :: mst_idx(:) + integer, intent(out) :: info + + integer :: i, j, proc, nov,isz, ip, err_act, idx + character(len=20) :: name + + name='psi_bld_ovr_mst' + call psb_get_erraction(err_act) + + nov = size(ovrlap_elem,1) + isz = 3*nov+1 + call psb_realloc(isz,mst_idx,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='reallocate') + goto 9999 + end if + mst_idx = -1 + j = 1 + do i=1, nov + proc = ovrlap_elem(i,3) + if (me /= proc) then + idx = ovrlap_elem(i,1) + mst_idx(j+0) = proc + mst_idx(j+1) = 1 + mst_idx(j+2) = idx + j = j + 3 + end if + end do + mst_idx(j) = -1 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine psi_bld_ovr_mst + diff --git a/base/serial/psi_serial_impl.f90 b/base/serial/psi_serial_impl.f90 new file mode 100644 index 00000000..d3149e26 --- /dev/null +++ b/base/serial/psi_serial_impl.f90 @@ -0,0 +1,1242 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psi_igthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + integer :: x(:), y(:), alpha, beta + + ! Locals + integer :: i + if (beta == izero) then + if (alpha == izero) then + do i=1,n + y(i) = izero + end do + else if (alpha == ione) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -ione) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == ione) then + ! Do nothing + else if (beta == -ione) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == izero) then + ! do nothing + else if (alpha == ione) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -ione) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_igthv + +subroutine psi_sgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_spk_) :: x(:), y(:), alpha, beta + + ! Locals + integer :: i + if (beta == szero) then + if (alpha == szero) then + do i=1,n + y(i) = szero + end do + else if (alpha == sone) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -sone) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == sone) then + ! Do nothing + else if (beta == -sone) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == szero) then + ! do nothing + else if (alpha == sone) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -sone) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_sgthv + +subroutine psi_dgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_dpk_) :: x(:), y(:), alpha, beta + + ! Locals + integer :: i + if (beta == dzero) then + if (alpha == dzero) then + do i=1,n + y(i) = dzero + end do + else if (alpha == done) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -done) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == done) then + ! Do nothing + else if (beta == -done) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == dzero) then + ! do nothing + else if (alpha == done) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -done) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_dgthv + +subroutine psi_cgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_spk_) :: x(:), y(:),alpha,beta + + ! Locals + integer :: i + if (beta == czero) then + if (alpha == czero) then + do i=1,n + y(i) = czero + end do + else if (alpha == cone) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -cone) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == cone) then + ! Do nothing + else if (beta == -cone) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == czero) then + ! do nothing + else if (alpha == cone) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -cone) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_cgthv + +subroutine psi_zgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_dpk_) :: x(:), y(:),alpha,beta + + ! Locals + integer :: i + if (beta == zzero) then + if (alpha == zzero) then + do i=1,n + y(i) = zzero + end do + else if (alpha == zone) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -zone) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == zone) then + ! Do nothing + else if (beta == -zone) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == zzero) then + ! do nothing + else if (alpha == zone) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -zone) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_zgthv + + + +subroutine psi_sgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(psb_spk_) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_sgthzmv + +subroutine psi_dgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(psb_dpk_) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_dgthzmv + + +subroutine psi_igthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + integer :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_igthzmv + + +subroutine psi_cgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(psb_spk_) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_cgthzmv + +subroutine psi_zgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(psb_dpk_) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_zgthzmv + +subroutine psi_sgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_spk_) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_sgthzv + +subroutine psi_dgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_dpk_) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_dgthzv + +subroutine psi_igthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + integer :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_igthzv + +subroutine psi_cgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_spk_) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_cgthzv + +subroutine psi_zgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_dpk_) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_zgthzv + + +subroutine psi_ssctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(psb_spk_) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == szero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == sone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_ssctmv + +subroutine psi_ssctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_spk_) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == szero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == sone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i)) + end do + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + end if +end subroutine psi_ssctv + + +subroutine psi_dsctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(psb_dpk_) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == dzero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == done) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_dsctmv + +subroutine psi_dsctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_dpk_) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == dzero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == done) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i)) + end do + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + end if +end subroutine psi_dsctv + +subroutine psi_isctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + integer :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == izero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == ione) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_isctmv + +subroutine psi_isctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + integer :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == izero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == ione) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if +end subroutine psi_isctv + +subroutine psi_csctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(psb_spk_) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == czero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == cone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_csctmv + + +subroutine psi_csctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_spk_) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == czero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == cone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if +end subroutine psi_csctv + +subroutine psi_zsctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(psb_dpk_) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == zzero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == zone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_zsctmv + + +subroutine psi_zsctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_dpk_) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == zzero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == zone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if +end subroutine psi_zsctv + + +subroutine psi_saxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + + integer, intent(in) :: m + real(psb_spk_), intent (in) :: x(:) + real(psb_spk_), intent (inout) :: y(:) + real(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (size(x) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + if (m>0) call saxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psi_saxpbyv +subroutine psi_saxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m, n + real(psb_spk_), intent (in) :: x(:,:) + real(psb_spk_), intent (inout) :: y(:,:) + real(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) + goto 9999 + end if + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) + goto 9999 + end if + + if ((m>0).and.(n>0)) call saxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psi_saxpby + +subroutine psi_daxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m + real(psb_dpk_), intent (in) :: x(:) + real(psb_dpk_), intent (inout) :: y(:) + real(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (size(x) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + if (m>0) call daxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psi_daxpbyv +subroutine psi_daxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m, n + real(psb_dpk_), intent (in) :: x(:,:) + real(psb_dpk_), intent (inout) :: y(:,:) + real(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) + goto 9999 + end if + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) + goto 9999 + end if + + if ((m>0).and.(n>0)) call daxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psi_daxpby + +subroutine psi_caxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m + complex(psb_spk_), intent (in) :: x(:) + complex(psb_spk_), intent (inout) :: y(:) + complex(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (size(x) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + if (m>0) call caxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psi_caxpbyv +subroutine psi_caxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m, n + complex(psb_spk_), intent (in) :: x(:,:) + complex(psb_spk_), intent (inout) :: y(:,:) + complex(psb_spk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) + goto 9999 + end if + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) + goto 9999 + end if + + if ((m>0).and.(n>0)) call caxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psi_caxpby + +subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m + complex(psb_dpk_), intent (in) :: x(:) + complex(psb_dpk_), intent (inout) :: y(:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (size(x) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + if (m>0) call zaxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psi_zaxpbyv +subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) + use psb_const_mod + use psb_error_mod + implicit none + integer, intent(in) :: m, n + complex(psb_dpk_), intent (in) :: x(:,:) + complex(psb_dpk_), intent (inout) :: y(:,:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,m,0,0,0/)) + goto 9999 + end if + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,n,0,0,0/)) + goto 9999 + end if + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/4,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/6,m,0,0,0/)) + goto 9999 + end if + + if ((m>0).and.(n>0)) call zaxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psi_zaxpby + diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index 1d4a6c03..11fffc30 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -2,7 +2,7 @@ BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO JAD -060 Domain size (acutal system is this**3) +020 Domain size (acutal system is this**3) 2 Stopping criterion 0100 MAXIT 01 ITRACE diff --git a/test/torture/Makefile b/test/torture/Makefile new file mode 100644 index 00000000..c853fbed --- /dev/null +++ b/test/torture/Makefile @@ -0,0 +1,37 @@ +include ../../Make.inc +# +# Libraries used +# +LIBDIR=../../lib/ +PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base +LDLIBS=$(PSBLDLIBS) +# +# Compilers and such +# +CCOPT= -g +FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). + +PSBTOBJS=psb_mvsv_tester.o psbtf.o +EXEDIR=./runs + + +all: psbtf + +psbtf: $(PSBTOBJS) + $(F90LINK) $(PSBTOBJS) -o psbtf $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psbtf $(EXEDIR) + +psbtf.o: psb_mvsv_tester.o +.f90.o: + $(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $< + + +clean: + /bin/rm -f $(PSBTOBJS) ppde.o spde.o $(EXEDIR)/ppde +verycleanlib: + (cd ../..; make veryclean) +lib: + (cd ../../; make library) + + + diff --git a/test/torture/psb_mvsv_tester.f90 b/test/torture/psb_mvsv_tester.f90 new file mode 100644 index 00000000..10573758 --- /dev/null +++ b/test/torture/psb_mvsv_tester.f90 @@ -0,0 +1,11089 @@ +module psb_mvsv_tester + +contains +subroutine s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=1 + ! 1 1 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 6/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_ap3_bp1_ix1_iy1 +! + +subroutine s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=1 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_ap3_bp1_ix1_iy1 +! + +subroutine s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=1 + ! 1 2 + ! 0 6 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 2, 6/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/6, 27/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_ap3_bp1_ix1_iy1 +! + +subroutine s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 2 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 3 + ! 2 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*4 :: VA(3)=(/1, 3, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/6, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=1 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*4 :: VA(1)=(/1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/4, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_ap1_bp1_ix1_iy1 +! + +subroutine s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=1 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/5, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_ap1_bp1_ix1_iy1 +! + +subroutine s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=1 + ! 1 2 + ! 5 1 + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + real*4 :: VA(4)=(/1, 2, 5, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/9, 6/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_ap1_bp1_ix1_iy1 +! + +subroutine s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 1 + ! 2 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*4 :: VA(3)=(/1, 1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/2, 2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 3 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + real*4 :: VA(4)=(/1, 3, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/2, 4/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 2, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/3, 1/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=1 + ! 1 3 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 3/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-1, 3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_am1_bp1_ix1_iy1 +! + +subroutine s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=1 + ! 1 1 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/2, 2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_am1_bp1_ix1_iy1 +! + +subroutine s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=1 + ! 1 0 + ! 1 2 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_am1_bp1_ix1_iy1 +! + +subroutine s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-1, -2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_am1_bm0_ix1_iy1 +! + +subroutine s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 4 + ! 3 1 + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + real*4 :: VA(4)=(/1, 4, 3, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-4, -5/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_am1_bm0_ix1_iy1 +! + +subroutine s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 1 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-1, -2/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_am1_bm0_ix1_iy1 +! + +subroutine s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=1 + ! 1 3 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 3, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-9, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_am3_bp1_ix1_iy1 +! + +subroutine s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=1 + ! 1 4 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*4 :: VA(3)=(/1, 4, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, -9/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_am3_bp1_ix1_iy1 +! + +subroutine s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=1 + ! 1 1 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/0, -3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_am3_bp1_ix1_iy1 +! + +subroutine s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 2 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + real*4 :: VA(2)=(/1, 2/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, -6/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_usmv_2_n_am3_bm0_ix1_iy1 +! + +subroutine s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*4 :: VA(1)=(/1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, 0/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_usmv_2_t_am3_bm0_ix1_iy1 +! + +subroutine s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/-3, -3/)! reference cy after + real*4 :: bcy(2)=(/3, 3/)! reference bcy before + real*4 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_usmv_2_c_am3_bm0_ix1_iy1 +! + +subroutine s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/3, 3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_ussv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/3, 3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_ussv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*4 :: alpha=3 + real*4 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 1, 1/) + real*4 :: x(2)=(/6, 3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,i,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_ussv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_ussv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_ussv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*4 :: alpha=1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/1, 1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_ussv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-1, -1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_ussv_2_n_am1_bm0_ix1_iy1 +! + +subroutine s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 3, 1/) + real*4 :: x(2)=(/-4, -1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_ussv_2_t_am1_bm0_ix1_iy1 +! + +subroutine s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*4 :: alpha=-1 + real*4 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*4 :: VA(3)=(/1, 2, 1/) + real*4 :: x(2)=(/-3, -1/)! reference x + real*4 :: cy(2)=(/1, 1/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_ussv_2_c_am1_bm0_ix1_iy1 +! + +subroutine s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-3, -3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine s_ussv_2_n_am3_bm0_ix1_iy1 +! + +subroutine s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-3, -3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine s_ussv_2_t_am3_bm0_ix1_iy1 +! + +subroutine s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_s_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*4 :: alpha=-3 + real*4 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*4 :: VA(2)=(/1, 1/) + real*4 :: x(2)=(/-3, -3/)! reference x + real*4 :: cy(2)=(/9, 9/)! reference cy after + real*4 :: bcy(2)=(/0, 0/)! reference bcy before + real*4 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine s_ussv_2_c_am3_bm0_ix1_iy1 +! + +subroutine d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=1 + ! 1 1 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/9, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_ap3_bp1_ix1_iy1 +! + +subroutine d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=1 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/6, 6/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_ap3_bp1_ix1_iy1 +! + +subroutine d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=1 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/15, 6/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_ap3_bp1_ix1_iy1 +! + +subroutine d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 3 + ! 3 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/12, 9/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 3 + ! 3 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/12, 9/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=1 + ! 1 0 + ! 0 2 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 2/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/4, 5/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_ap1_bp1_ix1_iy1 +! + +subroutine d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=1 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/5, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_ap1_bp1_ix1_iy1 +! + +subroutine d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=1 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/4, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_ap1_bp1_ix1_iy1 +! + +subroutine d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 3 4 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 4/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 7/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/2, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 0 3 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=1 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/2, 2/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_am1_bp1_ix1_iy1 +! + +subroutine d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=1 + ! 1 3 + ! 1 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_am1_bp1_ix1_iy1 +! + +subroutine d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=1 + ! 1 0 + ! 0 3 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/2, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_am1_bp1_ix1_iy1 +! + +subroutine d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 3 + ! 0 3 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-4, -3/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_am1_bm0_ix1_iy1 +! + +subroutine d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 3 5 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 5/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-4, -5/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_am1_bm0_ix1_iy1 +! + +subroutine d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 2 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 2/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-1, -2/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_am1_bm0_ix1_iy1 +! + +subroutine d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=1 + ! 1 0 + ! 0 6 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 6/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/0, -15/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_am3_bp1_ix1_iy1 +! + +subroutine d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=1 + ! 1 2 + ! 1 3 + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + real*8 :: VA(4)=(/1, 2, 1, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, -12/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_am3_bp1_ix1_iy1 +! + +subroutine d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=1 + ! 1 3 + ! 3 0 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + real*8 :: VA(3)=(/1, 3, 3/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-9, -6/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_am3_bp1_ix1_iy1 +! + +subroutine d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_usmv_2_n_am3_bm0_ix1_iy1 +! + +subroutine d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_usmv_2_t_am3_bm0_ix1_iy1 +! + +subroutine d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 0 + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + real*8 :: VA(1)=(/1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/-3, 0/)! reference cy after + real*8 :: bcy(2)=(/3, 3/)! reference bcy before + real*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_usmv_2_c_am3_bm0_ix1_iy1 +! + +subroutine d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/3, 12/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_ussv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 2, 1/) + real*8 :: x(2)=(/9, 3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_ussv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*8 :: alpha=3 + real*8 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/12, 3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_ussv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 3 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 3, 1/) + real*8 :: x(2)=(/1, 4/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_ussv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 1, 1/) + real*8 :: x(2)=(/2, 1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_ussv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*8 :: alpha=1 + real*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/1, 1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_ussv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 1, 1/) + real*8 :: x(2)=(/-1, -2/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_ussv_2_n_am1_bm0_ix1_iy1 +! + +subroutine d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 6 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 6, 1/) + real*8 :: x(2)=(/-7, -1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_ussv_2_t_am1_bm0_ix1_iy1 +! + +subroutine d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*8 :: alpha=-1 + real*8 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 2, 1/) + real*8 :: x(2)=(/-3, -1/)! reference x + real*8 :: cy(2)=(/1, 1/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_ussv_2_c_am1_bm0_ix1_iy1 +! + +subroutine d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + real*8 :: VA(3)=(/1, 1, 1/) + real*8 :: x(2)=(/-3, -6/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine d_ussv_2_n_am3_bm0_ix1_iy1 +! + +subroutine d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/-3, -3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine d_ussv_2_t_am3_bm0_ix1_iy1 +! + +subroutine d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_d_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + real*8 :: alpha=-3 + real*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + real*8 :: VA(2)=(/1, 1/) + real*8 :: x(2)=(/-3, -3/)! reference x + real*8 :: cy(2)=(/9, 9/)! reference cy after + real*8 :: bcy(2)=(/0, 0/)! reference bcy before + real*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine d_ussv_2_c_am3_bm0_ix1_iy1 +! + +subroutine c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 1+1i 2+2i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,1.e0), (2,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,3.e0), (12,9)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_ap3_bp1_ix1_iy1 +! + +subroutine c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 0+1i 2+6i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (0.e0,1.e0), (2,6)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,6.e0), (9,18)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_ap3_bp1_ix1_iy1 +! + +subroutine c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=1 + ! 1+1i 3+2i + ! 0+3i 2+0i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (3.e0,2.e0), (0.e0,3.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,-12.e0), (18,-6)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_ap3_bp1_ix1_iy1 +! + +subroutine c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 3+3i 6+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (3.e0,3.e0), (6,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(3.e0,3.e0), (27,9)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 1+2i 2+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,2.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(6.e0,9.e0), (6,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 0+0i 2+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,0.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(3.e0,-3.e0), (9,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 5+1i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (5,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(4.e0,1.e0), (8,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_ap1_bp1_ix1_iy1 +! + +subroutine c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=1 + ! 1+1i 1+0i + ! 0+1i 0+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (0.e0,1.e0), (0,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(4.e0,2.e0), (4,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_ap1_bp1_ix1_iy1 +! + +subroutine c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=1 + ! 1+1i 0+2i + ! 0+3i 2+0i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (0.e0,2.e0), (0.e0,3.e0), (2,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(4.e0,-4.e0), (5,-2)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_ap1_bp1_ix1_iy1 +! + +subroutine c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 0+0i 3+1i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,0.e0), (3,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(2.e0,1.e0), (3,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+1i 0+1i + ! 0+1i 3+5i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (0.e0,1.e0), (0.e0,1.e0), (3,5)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,2.e0), (3,6)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+1i 0+1i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (0,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,-1.e0), (0,-1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 0+0i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (1,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(2.e0,-1.e0), (2,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_am1_bp1_ix1_iy1 +! + +subroutine c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=1 + ! 1+1i 3+0i + ! 1+3i 0+2i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (3.e0,0.e0), (1.e0,3.e0), (0,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,-4.e0), (0,-2)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_am1_bp1_ix1_iy1 +! + +subroutine c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 1+2i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (1,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(1.e0,3.e0), (3,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_am1_bp1_ix1_iy1 +! + +subroutine c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 2+0i 1+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (2.e0,0.e0), (1,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-2.e0,-1.e0), (-3,-1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_am1_bm0_ix1_iy1 +! + +subroutine c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+1i 1+3i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (1,3)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-1.e0,-1.e0), (-1,-3)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_am1_bm0_ix1_iy1 +! + +subroutine c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+1i 1+0i + ! 0+1i 5+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (0.e0,1.e0), (5,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-1.e0,2.e0), (-6,1)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_am1_bm0_ix1_iy1 +! + +subroutine c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=1 + ! 1+1i 0+0i + ! 3+1i 2+4i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (3.e0,1.e0), (2,4)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(0.e0,-3.e0), (-12,-15)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_am3_bp1_ix1_iy1 +! + +subroutine c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=1 + ! 1+1i 0+1i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 1/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/(1.e0,1.e0), (0,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(0.e0,-3.e0), (3,-3)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_am3_bp1_ix1_iy1 +! + +subroutine c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=1 + ! 1+1i 1+0i + ! 1+1i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,0.e0), (1,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-3.e0,6.e0), (0,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_am3_bp1_ix1_iy1 +! + +subroutine c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 0+2i 0+2i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (0.e0,2.e0), (0,2)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-3.e0,-3.e0), (0,-12)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_usmv_2_n_am3_bm0_ix1_iy1 +! + +subroutine c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+1i 0+0i + ! 1+3i 3+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,1.e0), (1.e0,3.e0), (3,0)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-6.e0,-12.e0), (-9,0)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_usmv_2_t_am3_bm0_ix1_iy1 +! + +subroutine c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+1i 3+1i + ! 0+1i 3+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*8 :: VA(4)=(/(1.e0,1.e0), (3.e0,1.e0), (0.e0,1.e0), (3,1)/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/(-3.e0,6.e0), (-18,6)/)! reference cy after + complex*8 :: bcy(2)=(/3, 3/)! reference bcy before + complex*8 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_usmv_2_c_am3_bm0_ix1_iy1 +! + +subroutine c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/1, 1, 1/) + complex*8 :: x(2)=(/3, 6/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_ussv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+2i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,2.e0), (1,0)/) + complex*8 :: x(2)=(/(3.e0,6.e0), (3,0)/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_ussv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*8 :: alpha=3 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,4.e0), (1,0)/) + complex*8 :: x(2)=(/(3.e0,-12.e0), (3,0)/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_ussv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+1i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,1.e0), (1,0)/) + complex*8 :: x(2)=(/(1.e0,0.e0), (1,1)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_ussv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/1, 1/) + complex*8 :: x(2)=(/1, 1/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_ussv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*8 :: alpha=1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 3+3i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (3.e0,3.e0), (1,0)/) + complex*8 :: x(2)=(/(4.e0,-3.e0), (1,0)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_ussv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1 0 + ! 5 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/1, 5, 1/) + complex*8 :: x(2)=(/-1, -6/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_ussv_2_n_am1_bm0_ix1_iy1 +! + +subroutine c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 1+2i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (1.e0,2.e0), (1,0)/) + complex*8 :: x(2)=(/(-2.e0,-2.e0), (-1,0)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_ussv_2_t_am1_bm0_ix1_iy1 +! + +subroutine c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*8 :: alpha=-1 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (0.e0,4.e0), (1,0)/) + complex*8 :: x(2)=(/(-1.e0,4.e0), (-1,0)/)! reference x + complex*8 :: cy(2)=(/1, 1/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_ussv_2_c_am1_bm0_ix1_iy1 +! + +subroutine c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1+0i 0+0i + ! 1+1i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*8 :: VA(3)=(/(1.e0,0.e0), (1.e0,1.e0), (1,0)/) + complex*8 :: x(2)=(/(-3.e0,0.e0), (-6,-3)/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine c_ussv_2_n_am3_bm0_ix1_iy1 +! + +subroutine c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/1, 1/) + complex*8 :: x(2)=(/-3, -3/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine c_ussv_2_t_am3_bm0_ix1_iy1 +! + +subroutine c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_c_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*8 :: alpha=-3 + complex*8 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*8 :: VA(2)=(/1, 1/) + complex*8 :: x(2)=(/-3, -3/)! reference x + complex*8 :: cy(2)=(/9, 9/)! reference cy after + complex*8 :: bcy(2)=(/0, 0/)! reference bcy before + complex*8 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine c_ussv_2_c_am3_bm0_ix1_iy1 +! + +subroutine z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=1 + ! 1+1i 1+0i + ! 5+1i 1+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (5.e0,1.e0), (1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(9.e0,3.e0), (21,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_ap3_bp1_ix1_iy1 +! + +subroutine z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 2+3i 2+2i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (2.e0,3.e0), (2,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(12.e0,12.e0), (9,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_ap3_bp1_ix1_iy1 +! + +subroutine z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 2+0i 1+3i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (2.e0,0.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(12.e0,-3.e0), (6,-9)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_ap3_bp1_ix1_iy1 +! + +subroutine z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 0+0i 0+2i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (0,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(3.e0,3.e0), (0,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+1i 0+1i + ! 1+0i 3+0i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (0.e0,1.e0), (1.e0,0.e0), (3,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(6.e0,3.e0), (9,3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 1+3i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(6.e0,-12.e0), (0,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+3i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (0,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,1.e0), (3,3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_ap1_bp1_ix1_iy1 +! + +subroutine z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+1i 1+3i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,1.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,2.e0), (4,3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_ap1_bp1_ix1_iy1 +! + +subroutine z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=1 + ! 1+1i 1+3i + ! 0+0i 0+2i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (1.e0,3.e0), (0,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,-1.e0), (4,-5)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_ap1_bp1_ix1_iy1 +! + +subroutine z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+1i 3+2i + ! 0+0i 0+4i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (3.e0,2.e0), (0,4)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(4.e0,3.e0), (0,4)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,4.e0), (1,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(1.e0,5.e0), (1,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 1+3i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 1/) + complex*16 :: VA(2)=(/(1.e0,1.e0), (1,3)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,-4.e0), (0,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 3+2i 1+1i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (3.e0,2.e0), (1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,-1.e0), (-1,-3)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_am1_bp1_ix1_iy1 +! + +subroutine z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+3i 0+1i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,3.e0), (0,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,-4.e0), (3,-1)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_am1_bp1_ix1_iy1 +! + +subroutine z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 0+4i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,4.e0), (1,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(2.e0,5.e0), (2,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_am1_bp1_ix1_iy1 +! + +subroutine z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 5+3i 2+2i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (5.e0,3.e0), (2,2)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-1.e0,-1.e0), (-7,-5)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_am1_bm0_ix1_iy1 +! + +subroutine z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1+1i 1+0i + ! 0+3i 3+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (1.e0,0.e0), (0.e0,3.e0), (3,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-1.e0,-4.e0), (-4,-1)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_am1_bm0_ix1_iy1 +! + +subroutine z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1+1i 2+0i + ! 1+0i 0+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (2.e0,0.e0), (1.e0,0.e0), (0,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-2.e0,1.e0), (-2,1)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_am1_bm0_ix1_iy1 +! + +subroutine z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 2+3i 0+1i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (2.e0,3.e0), (0,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(0.e0,-3.e0), (-3,-12)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_am3_bp1_ix1_iy1 +! + +subroutine z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=1 + ! 1+1i 0+0i + ! 1+4i 2+4i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (1.e0,4.e0), (2,4)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,-15.e0), (-3,-12)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_am3_bp1_ix1_iy1 +! + +subroutine z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=1 + ! 1+1i 0+2i + ! 2+0i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 1, 2/) + integer :: JA(3)=(/1, 2, 1/) + complex*16 :: VA(3)=(/(1.e0,1.e0), (0.e0,2.e0), (2,0)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-6.e0,3.e0), (3,6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_am3_bp1_ix1_iy1 +! + +subroutine z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+1i 0+3i + ! 0+1i 1+1i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (0.e0,3.e0), (0.e0,1.e0), (1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,-12.e0), (-3,-6)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_usmv_2_n_am3_bm0_ix1_iy1 +! + +subroutine z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+1i 0+1i + ! 0+3i 1+5i + + ! declaration of VA,IA,JA + integer :: nnz=4 + integer :: m=2 + integer :: k=2 + integer :: IA(4)=(/1, 1, 2, 2/) + integer :: JA(4)=(/1, 2, 1, 2/) + complex*16 :: VA(4)=(/(1.e0,1.e0), (0.e0,1.e0), (0.e0,3.e0), (1,5)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,-12.e0), (-3,-18)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_usmv_2_t_am3_bm0_ix1_iy1 +! + +subroutine z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + integer :: incy=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+1i 0+0i + ! 0+0i 0+0i + + ! declaration of VA,IA,JA + integer :: nnz=1 + integer :: m=2 + integer :: k=2 + integer :: IA(1)=(/1/) + integer :: JA(1)=(/1/) + complex*16 :: VA(1)=(/(1,1)/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/(-3.e0,3.e0), (0,0)/)! reference cy after + complex*16 :: bcy(2)=(/3, 3/)! reference bcy before + complex*16 :: y(2)=(/3, 3/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spmm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spmm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_usmv_2_c_am3_bm0_ix1_iy1 +! + +subroutine z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 0+2i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (0.e0,2.e0), (1,0)/) + complex*16 :: x(2)=(/(3.e0,0.e0), (3,6)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_ussv_2_n_ap3_bm0_ix1_iy1 +! + +subroutine z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 0+1i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (0.e0,1.e0), (1,0)/) + complex*16 :: x(2)=(/(3.e0,3.e0), (3,0)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_ussv_2_t_ap3_bm0_ix1_iy1 +! + +subroutine z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*16 :: alpha=3 + complex*16 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 1, 1/) + complex*16 :: x(2)=(/6, 3/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_ussv_2_c_ap3_bm0_ix1_iy1 +! + +subroutine z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 1+5i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (1.e0,5.e0), (1,0)/) + complex*16 :: x(2)=(/(1.e0,0.e0), (2,5)/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_ussv_2_n_ap1_bm0_ix1_iy1 +! + +subroutine z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*16 :: VA(2)=(/1, 1/) + complex*16 :: x(2)=(/1, 1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_ussv_2_t_ap1_bm0_ix1_iy1 +! + +subroutine z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*16 :: alpha=1 + complex*16 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 2, 1/) + complex*16 :: x(2)=(/3, 1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_ussv_2_c_ap1_bm0_ix1_iy1 +! + +subroutine z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 2, 1/) + complex*16 :: x(2)=(/-1, -3/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_ussv_2_n_am1_bm0_ix1_iy1 +! + +subroutine z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1 0 + ! 0 1 + + ! declaration of VA,IA,JA + integer :: nnz=2 + integer :: m=2 + integer :: k=2 + integer :: IA(2)=(/1, 2/) + integer :: JA(2)=(/1, 2/) + complex*16 :: VA(2)=(/1, 1/) + complex*16 :: x(2)=(/-1, -1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_ussv_2_t_am1_bm0_ix1_iy1 +! + +subroutine z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*16 :: alpha=-1 + complex*16 :: beta=0 + ! 1 0 + ! 2 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 2, 1/) + complex*16 :: x(2)=(/-3, -1/)! reference x + complex*16 :: cy(2)=(/1, 1/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_ussv_2_c_am1_bm0_ix1_iy1 +! + +subroutine z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='n' + integer :: incx=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1 0 + ! 1 1 + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/1, 1, 1/) + complex*16 :: x(2)=(/-3, -6/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" +end subroutine z_ussv_2_n_am3_bm0_ix1_iy1 +! + +subroutine z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='t' + integer :: incx=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 1+3i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (1.e0,3.e0), (1,0)/) + complex*16 :: x(2)=(/(-6.e0,-9.e0), (-3,0)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" +end subroutine z_ussv_2_t_am3_bm0_ix1_iy1 +! + +subroutine z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + use psb_sparse_mod + implicit none + character(len=*) :: afmt + type(psb_z_sparse_mat) :: a + type(psb_desc_type) :: desc_a + integer :: ictxt, iam=-1, np=-1 + integer :: info=-1 + + integer::res,istat=0,i + character::transa='c' + integer :: incx=1 + complex*16 :: alpha=-3 + complex*16 :: beta=0 + ! 1+0i 0+0i + ! 2+3i 1+0i + + ! declaration of VA,IA,JA + integer :: nnz=3 + integer :: m=2 + integer :: k=2 + integer :: IA(3)=(/1, 2, 2/) + integer :: JA(3)=(/1, 1, 2/) + complex*16 :: VA(3)=(/(1.e0,0.e0), (2.e0,3.e0), (1,0)/) + complex*16 :: x(2)=(/(-9.e0,9.e0), (-3,0)/)! reference x + complex*16 :: cy(2)=(/9, 9/)! reference cy after + complex*16 :: bcy(2)=(/0, 0/)! reference bcy before + complex*16 :: y(2)=(/0, 0/)! y + + y=bcy + res=0 + call psb_info(ictxt,iam,np) + if(iam<0)then + info=-1 + goto 9999 + endif + call psb_barrier(ictxt) + call psb_cdall(ictxt,desc_a,info,nl=m) + if (info /= 0)goto 9996 + call psb_spall(a,desc_a,info,nnz=nnz) + if (info /= 0)goto 9996 + call a%set_triangle() + call a%set_lower() + call a%set_unit(.false.) + + call psb_barrier(ictxt) + call psb_spins(nnz,IA,JA,VA,a,desc_a,info) + if (info /= 0)goto 9996 + call psb_cdasb(desc_a,info) + if (info /= 0)goto 9996 + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + if(info.ne.0)print *,"matrix assembly failed" + if(info.ne.0)goto 9996 + + call psb_spsm(alpha,A,x,beta,y,desc_a,info,transa) + if(info.ne.0)print *,"psb_spsm failed" + if(info.ne.0)goto 9996 + do i=1,2 + if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i)/=cy(i))info=-1 + if(y(i)/=cy(i))goto 9996 + enddo +9996 continue + if(info /= 0)res=res+1 + call psb_spfree(a,desc_a,info) + if (info /= 0)goto 9997 +9997 continue + if(info /= 0)res=res+1 + call psb_cdfree(desc_a,info) + if (info /= 0)goto 9998 +9998 continue + if(info /= 0)res=res+1 +9999 continue + if(info /= 0)res=res+1 + if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" +end subroutine z_ussv_2_c_am3_bm0_ix1_iy1 +end module psb_mvsv_tester diff --git a/test/torture/psbtf.f90 b/test/torture/psbtf.f90 new file mode 100644 index 00000000..aedb2292 --- /dev/null +++ b/test/torture/psbtf.f90 @@ -0,0 +1,754 @@ +! +! Parallel Sparse BLAS fortran interface testing code +! +! +! + +program main + + use psb_sparse_mod + use psb_mvsv_tester + implicit none + integer, parameter :: psb_fidasize_=16 + integer :: res,passed=0,failed=0; + integer :: ictxt, iam=-1, np=-1 + character(len=psb_fidasize_) :: afmt + + write(*,*) 'Format ?' + read(*,*) afmt +! afmt = 'COO' + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + if(iam<0)then + goto 9999 + endif + call s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + + call z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + if(res/=0)failed=failed+1 + if(res.eq.0)passed=passed+1 + res=0 + +9999 continue + print *,"PASSED:",passed + print *,"FAILED:",failed + call psb_exit(ictxt) + +end program main + + + diff --git a/util/Makefile b/util/Makefile index fa300ea3..1d3227f5 100644 --- a/util/Makefile +++ b/util/Makefile @@ -6,11 +6,12 @@ LIBDIR=../lib HERE=. BASEOBJS= psb_blockpart_mod.o psb_metispart_mod.o \ - psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o -MODOBJ=psb_util_mod.o -OBJS=$(BASEOBJS) $(MODOBJ) + psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o +IMPLOBJS= psb_hbio_impl.o psb_mmio_impl.o psb_mat_dist_impl.o +MODOBJS=psb_util_mod.o $(BASEOBJS) +OBJS=$(MODOBJS) $(IMPLOBJS) LIBMOD=psb_util_mod$(.mod) -LOCAL_MODS=$(OBJS:.o=$(.mod)) +LOCAL_MODS=$(MODOBJS:.o=$(.mod)) LIBNAME=$(UTILLIBNAME) FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). @@ -23,7 +24,6 @@ lib: $(OBJS) psb_util_mod.o: $(BASEOBJS) -psb_read_mat_mod.o: psb_mmio_mod.o veryclean: clean /bin/rm -f $(HERE)/$(LIBNAME) diff --git a/util/psb_hbio_impl.f90 b/util/psb_hbio_impl.f90 new file mode 100644 index 00000000..13d1bae8 --- /dev/null +++ b/util/psb_hbio_impl.f90 @@ -0,0 +1,1320 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_s_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_s_csc_sparse_mat) :: acsc + type(psb_s_coo_sparse_mat) :: acoo + integer :: ircode, i,nzr,infile, info + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(0,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode==0) call a%mv_from(acoo) + if (ircode/=0) goto 993 + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile/=5) close(infile) + + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'HB_READ: Memory allocation failure' + return +end subroutine shb_read + +subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_s_sparse_mat), intent(in), target :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_spk_), optional :: rhs(:), g(:), x(:) + integer :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer, parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer, parameter :: jval=4,jrhs=4 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_s_csc_sparse_mat), target :: acsc + type(psb_s_csc_sparse_mat), pointer :: acpnt + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + select type(aa=>a%a) + type is (psb_s_csc_sparse_mat) + + acpnt => aa + + class default + + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc + + end select + + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return +end subroutine shb_write + + + +subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_d_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_d_csc_sparse_mat) :: acsc + type(psb_d_coo_sparse_mat) :: acoo + integer :: ircode, i,nzr,infile, info + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(0,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode==0) call a%mv_from(acoo) + if (ircode/=0) goto 993 + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile/=5) close(infile) + + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'HB_READ: Memory allocation failure' + return +end subroutine dhb_read + +subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_d_sparse_mat), intent(in), target :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_dpk_), optional :: rhs(:), g(:), x(:) + integer :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer, parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer, parameter :: jval=4,jrhs=4 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_d_csc_sparse_mat), target :: acsc + type(psb_d_csc_sparse_mat), pointer :: acpnt + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + select type(aa=>a%a) + type is (psb_d_csc_sparse_mat) + + acpnt => aa + + class default + + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc + + end select + + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return +end subroutine dhb_write + + + + +subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_c_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_c_csc_sparse_mat) :: acsc + type(psb_c_coo_sparse_mat) :: acoo + integer :: ircode, i,nzr,infile, info + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(0,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'c') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode==0) call a%mv_from(acoo) + if (ircode/=0) goto 993 + + else if (psb_tolower(type(2:2)) == 'h') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode==0) call a%mv_from(acoo) + if (ircode/=0) goto 993 + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile/=5) close(infile) + + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'HB_READ: Memory allocation failure' + return +end subroutine chb_read + +subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_c_sparse_mat), intent(in), target :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_spk_), optional :: rhs(:), g(:), x(:) + integer :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer, parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer, parameter :: jval=2,jrhs=2 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_c_csc_sparse_mat), target :: acsc + type(psb_c_csc_sparse_mat), pointer :: acpnt + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + select type(aa=>a%a) + type is (psb_c_csc_sparse_mat) + + acpnt => aa + + class default + + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc + + end select + + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'CUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return +end subroutine chb_write + + + +subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_z_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_z_csc_sparse_mat) :: acsc + type(psb_z_coo_sparse_mat) :: acoo + integer :: ircode, i,nzr,infile, info + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(0,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'c') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode==0) call a%mv_from(acoo) + if (ircode/=0) goto 993 + + else if (psb_tolower(type(2:2)) == 'h') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode==0) call a%mv_from(acoo) + if (ircode/=0) goto 993 + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile/=5) close(infile) + + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'HB_READ: Memory allocation failure' + return +end subroutine zhb_read + +subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod + implicit none + type(psb_z_sparse_mat), intent(in), target :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_dpk_), optional :: rhs(:), g(:), x(:) + integer :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer, parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer, parameter :: jval=2,jrhs=2 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_z_csc_sparse_mat), target :: acsc + type(psb_z_csc_sparse_mat), pointer :: acpnt + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + select type(aa=>a%a) + type is (psb_z_csc_sparse_mat) + + acpnt => aa + + class default + + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc + + end select + + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'CUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return +end subroutine zhb_write + diff --git a/util/psb_hbio_mod.f90 b/util/psb_hbio_mod.f90 index 6f406d74..d197a945 100644 --- a/util/psb_hbio_mod.f90 +++ b/util/psb_hbio_mod.f90 @@ -33,1301 +33,93 @@ module psb_hbio_mod public hb_read, hb_write interface hb_read - module procedure shb_read, dhb_read, zhb_read, chb_read + subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod, only : psb_s_sparse_mat, psb_spk_ + implicit none + type(psb_s_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine shb_read + subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod, only : psb_d_sparse_mat, psb_dpk_ + implicit none + type(psb_d_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine dhb_read + subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod, only : psb_c_sparse_mat, psb_spk_ + implicit none + type(psb_c_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine chb_read + subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_sparse_mod, only : psb_z_sparse_mat, psb_dpk_ + implicit none + type(psb_z_sparse_mat), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine zhb_read end interface + interface hb_write - module procedure shb_write, dhb_write,zhb_write, chb_write + subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod, only : psb_s_sparse_mat, psb_spk_ + implicit none + type(psb_s_sparse_mat), intent(inout) :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_spk_), optional :: rhs(:), g(:), x(:) + end subroutine shb_write + subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod, only : psb_d_sparse_mat, psb_dpk_ + implicit none + type(psb_d_sparse_mat), intent(inout) :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_dpk_), optional :: rhs(:), g(:), x(:) + end subroutine dhb_write + subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod, only : psb_c_sparse_mat, psb_spk_ + implicit none + type(psb_c_sparse_mat), intent(inout) :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_spk_), optional :: rhs(:), g(:), x(:) + end subroutine chb_write + subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_sparse_mod, only : psb_z_sparse_mat, psb_dpk_ + implicit none + type(psb_z_sparse_mat), intent(inout) :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_dpk_), optional :: rhs(:), g(:), x(:) + end subroutine zhb_write end interface -contains - - subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_s_sparse_mat), intent(out) :: a - integer, intent(out) :: iret - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - real(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) - character(len=72), optional, intent(out) :: mtitle - - character :: rhstype*3,type*3,key*8 - character(len=72) :: mtitle_ - character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 - integer :: indcrd, ptrcrd, totcrd,& - & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_s_csc_sparse_mat) :: acsc - type(psb_s_coo_sparse_mat) :: acoo - integer :: ircode, i,nzr,infile, info - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - - call acsc%allocate(nrow,ncol,nnzero) - if (ircode /= 0 ) then - write(0,*) 'Memory allocation failed' - goto 993 - end if - - if (present(mtitle)) mtitle=mtitle_ - - - if (psb_tolower(type(1:1)) == 'r') then - if (psb_tolower(type(2:2)) == 'u') then - - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - call a%mv_from(acsc) - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - else if (psb_tolower(type(2:2)) == 's') then - - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - - call acoo%mv_from_fmt(acsc,info) - call acoo%reallocate(2*nnzero) - ! A is now in COO format - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 - - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - - call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) - - return - - ! open failed -901 iret=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 iret=902 - write(0,*) 'HB_READ: Unexpected end of file ' - return -993 iret=993 - write(0,*) 'HB_READ: Memory allocation failure' - return - end subroutine shb_read - - subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_s_sparse_mat), intent(in), target :: a - integer, intent(out) :: iret - character(len=*), optional, intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character(len=*), optional, intent(in) :: key - real(psb_spk_), optional :: rhs(:), g(:), x(:) - integer :: iout - - character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' - integer, parameter :: jptr=10,jind=10 - character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' - integer, parameter :: jval=4,jrhs=4 - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - type(psb_s_csc_sparse_mat), target :: acsc - type(psb_s_csc_sparse_mat), pointer :: acpnt - character(len=72) :: mtitle_ - character(len=8) :: key_ - - character :: rhstype*3,type*3 - - integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& - & nrow,ncol,nnzero, neltvl, nrhs, nrhsix - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - if (present(mtitle)) then - mtitle_ = mtitle - else - mtitle_ = 'Temporary PSBLAS title ' - endif - if (present(key)) then - key_ = key - else - key_ = 'PSBMAT00' - endif - - - select type(aa=>a%a) - type is (psb_s_csc_sparse_mat) - - acpnt => aa - - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() - - neltvl = 0 - - ptrcrd = (ncol+1)/jptr - if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'RUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) - - - - - if (iout /= 6) close(iout) - - - return - -901 continue - iret=901 - write(0,*) 'Error while opening ',filename - return - end subroutine shb_write - - - - subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_d_sparse_mat), intent(out) :: a - integer, intent(out) :: iret - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - real(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) - character(len=72), optional, intent(out) :: mtitle - - character :: rhstype*3,type*3,key*8 - character(len=72) :: mtitle_ - character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 - integer :: indcrd, ptrcrd, totcrd,& - & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_d_csc_sparse_mat) :: acsc - type(psb_d_coo_sparse_mat) :: acoo - integer :: ircode, i,nzr,infile, info - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - - call acsc%allocate(nrow,ncol,nnzero) - if (ircode /= 0 ) then - write(0,*) 'Memory allocation failed' - goto 993 - end if - - if (present(mtitle)) mtitle=mtitle_ - - - if (psb_tolower(type(1:1)) == 'r') then - if (psb_tolower(type(2:2)) == 'u') then - - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - call a%mv_from(acsc) - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - else if (psb_tolower(type(2:2)) == 's') then - - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - - call acoo%mv_from_fmt(acsc,info) - call acoo%reallocate(2*nnzero) - ! A is now in COO format - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 - - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - - call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) - - return - - ! open failed -901 iret=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 iret=902 - write(0,*) 'HB_READ: Unexpected end of file ' - return -993 iret=993 - write(0,*) 'HB_READ: Memory allocation failure' - return - end subroutine dhb_read - - subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_d_sparse_mat), intent(in), target :: a - integer, intent(out) :: iret - character(len=*), optional, intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character(len=*), optional, intent(in) :: key - real(psb_dpk_), optional :: rhs(:), g(:), x(:) - integer :: iout - - character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' - integer, parameter :: jptr=10,jind=10 - character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' - integer, parameter :: jval=4,jrhs=4 - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - type(psb_d_csc_sparse_mat), target :: acsc - type(psb_d_csc_sparse_mat), pointer :: acpnt - character(len=72) :: mtitle_ - character(len=8) :: key_ - - character :: rhstype*3,type*3 - - integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& - & nrow,ncol,nnzero, neltvl, nrhs, nrhsix - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - if (present(mtitle)) then - mtitle_ = mtitle - else - mtitle_ = 'Temporary PSBLAS title ' - endif - if (present(key)) then - key_ = key - else - key_ = 'PSBMAT00' - endif - - - select type(aa=>a%a) - type is (psb_d_csc_sparse_mat) - - acpnt => aa - - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() - - neltvl = 0 - - ptrcrd = (ncol+1)/jptr - if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'RUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) - - - - - if (iout /= 6) close(iout) - - - return - -901 continue - iret=901 - write(0,*) 'Error while opening ',filename - return - end subroutine dhb_write - - - - - subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_c_sparse_mat), intent(out) :: a - integer, intent(out) :: iret - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - complex(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) - character(len=72), optional, intent(out) :: mtitle - - character :: rhstype*3,type*3,key*8 - character(len=72) :: mtitle_ - character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 - integer :: indcrd, ptrcrd, totcrd,& - & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_c_csc_sparse_mat) :: acsc - type(psb_c_coo_sparse_mat) :: acoo - integer :: ircode, i,nzr,infile, info - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - - call acsc%allocate(nrow,ncol,nnzero) - if (ircode /= 0 ) then - write(0,*) 'Memory allocation failed' - goto 993 - end if - - if (present(mtitle)) mtitle=mtitle_ - - - if (psb_tolower(type(1:1)) == 'c') then - if (psb_tolower(type(2:2)) == 'u') then - - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - call a%mv_from(acsc) - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - else if (psb_tolower(type(2:2)) == 's') then - - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - - call acoo%mv_from_fmt(acsc,info) - call acoo%reallocate(2*nnzero) - ! A is now in COO format - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 - - else if (psb_tolower(type(2:2)) == 'h') then - - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - - call acoo%mv_from_fmt(acsc,info) - call acoo%reallocate(2*nnzero) - ! A is now in COO format - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = conjg(acoo%val(i)) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 - - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - - call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) - - return - - ! open failed -901 iret=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 iret=902 - write(0,*) 'HB_READ: Unexpected end of file ' - return -993 iret=993 - write(0,*) 'HB_READ: Memory allocation failure' - return - end subroutine chb_read - - subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_c_sparse_mat), intent(in), target :: a - integer, intent(out) :: iret - character(len=*), optional, intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character(len=*), optional, intent(in) :: key - complex(psb_spk_), optional :: rhs(:), g(:), x(:) - integer :: iout - - character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' - integer, parameter :: jptr=10,jind=10 - character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' - integer, parameter :: jval=2,jrhs=2 - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - type(psb_c_csc_sparse_mat), target :: acsc - type(psb_c_csc_sparse_mat), pointer :: acpnt - character(len=72) :: mtitle_ - character(len=8) :: key_ - - character :: rhstype*3,type*3 - - integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& - & nrow,ncol,nnzero, neltvl, nrhs, nrhsix - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - if (present(mtitle)) then - mtitle_ = mtitle - else - mtitle_ = 'Temporary PSBLAS title ' - endif - if (present(key)) then - key_ = key - else - key_ = 'PSBMAT00' - endif - - - select type(aa=>a%a) - type is (psb_c_csc_sparse_mat) - - acpnt => aa - - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() - - neltvl = 0 - - ptrcrd = (ncol+1)/jptr - if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'CUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) - - - - - if (iout /= 6) close(iout) - - - return - -901 continue - iret=901 - write(0,*) 'Error while opening ',filename - return - end subroutine chb_write - - - - subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_z_sparse_mat), intent(out) :: a - integer, intent(out) :: iret - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - complex(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) - character(len=72), optional, intent(out) :: mtitle - - character :: rhstype*3,type*3,key*8 - character(len=72) :: mtitle_ - character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 - integer :: indcrd, ptrcrd, totcrd,& - & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_z_csc_sparse_mat) :: acsc - type(psb_z_coo_sparse_mat) :: acoo - integer :: ircode, i,nzr,infile, info - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - - call acsc%allocate(nrow,ncol,nnzero) - if (ircode /= 0 ) then - write(0,*) 'Memory allocation failed' - goto 993 - end if - - if (present(mtitle)) mtitle=mtitle_ - - - if (psb_tolower(type(1:1)) == 'c') then - if (psb_tolower(type(2:2)) == 'u') then - - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - call a%mv_from(acsc) - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - else if (psb_tolower(type(2:2)) == 's') then - - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - - call acoo%mv_from_fmt(acsc,info) - call acoo%reallocate(2*nnzero) - ! A is now in COO format - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 - - else if (psb_tolower(type(2:2)) == 'h') then - - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - - read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) - read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - - - if (present(b)) then - if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,b,info) - read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) - endif - endif - if (present(g)) then - if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,g,info) - read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) - endif - endif - if (present(x)) then - if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then - call psb_realloc(nrow,1,x,info) - read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) - endif - endif - - - call acoo%mv_from_fmt(acsc,info) - call acoo%reallocate(2*nnzero) - ! A is now in COO format - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = conjg(acoo%val(i)) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 - - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - else - write(0,*) 'read_matrix: matrix type not yet supported' - iret=904 - end if - - call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) - - return - - ! open failed -901 iret=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 iret=902 - write(0,*) 'HB_READ: Unexpected end of file ' - return -993 iret=993 - write(0,*) 'HB_READ: Memory allocation failure' - return - end subroutine zhb_read - - subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) - use psb_sparse_mod - implicit none - type(psb_z_sparse_mat), intent(in), target :: a - integer, intent(out) :: iret - character(len=*), optional, intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character(len=*), optional, intent(in) :: key - complex(psb_dpk_), optional :: rhs(:), g(:), x(:) - integer :: iout - - character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' - integer, parameter :: jptr=10,jind=10 - character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' - integer, parameter :: jval=2,jrhs=2 - character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' - character(len=*), parameter :: fmt11='(a3,11x,2i14)' - character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - - type(psb_z_csc_sparse_mat), target :: acsc - type(psb_z_csc_sparse_mat), pointer :: acpnt - character(len=72) :: mtitle_ - character(len=8) :: key_ - - character :: rhstype*3,type*3 - - integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& - & nrow,ncol,nnzero, neltvl, nrhs, nrhsix - - iret = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - if (present(mtitle)) then - mtitle_ = mtitle - else - mtitle_ = 'Temporary PSBLAS title ' - endif - if (present(key)) then - key_ = key - else - key_ = 'PSBMAT00' - endif - - - select type(aa=>a%a) - type is (psb_z_csc_sparse_mat) - - acpnt => aa - - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() - - neltvl = 0 - - ptrcrd = (ncol+1)/jptr - if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'CUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) - - - - - if (iout /= 6) close(iout) - - - return - -901 continue - iret=901 - write(0,*) 'Error while opening ',filename - return - end subroutine zhb_write - end module psb_hbio_mod diff --git a/util/psb_mat_dist_impl.f90 b/util/psb_mat_dist_impl.f90 new file mode 100644 index 00000000..4b0edb32 --- /dev/null +++ b/util/psb_mat_dist_impl.f90 @@ -0,0 +1,1810 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine smatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_s_sparse_mat) :: a_glob + real(psb_spk_) :: b_glob(:) + integer :: ictxt + type(psb_s_sparse_mat) :: a + real(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + ! local variables + logical :: use_parts, use_v + integer :: np, iam + integer :: length_row, i_count, j_count,& + & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + integer, parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=581 + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else + call psb_cdall(ictxt,desc_a,info,vg=v) + end if + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, length_row) + if (length_row == 1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + end if + else + length_row = 1 + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + if (length_row == 1) then + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine smatdist + + +subroutine dmatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_d_sparse_mat) :: a_glob + real(psb_dpk_) :: b_glob(:) + integer :: ictxt + type(psb_d_sparse_mat) :: a + real(psb_dpk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + ! local variables + logical :: use_parts, use_v + integer :: np, iam + integer :: length_row, i_count, j_count,& + & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + integer, parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=581 + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else + call psb_cdall(ictxt,desc_a,info,vg=v) + end if + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, length_row) + if (length_row == 1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + end if + else + length_row = 1 + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + if (length_row == 1) then + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine dmatdist + + +subroutine cmatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_c_sparse_mat) :: a_glob + complex(psb_spk_) :: b_glob(:) + integer :: ictxt + type(psb_c_sparse_mat) :: a + complex(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + ! local variables + logical :: use_parts, use_v + integer :: np, iam + integer :: length_row, i_count, j_count,& + & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + complex(psb_spk_), allocatable :: val(:) + integer, parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=581 + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else + call psb_cdall(ictxt,desc_a,info,vg=v) + end if + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, length_row) + if (length_row == 1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + end if + else + length_row = 1 + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + if (length_row == 1) then + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine cmatdist + + +subroutine zmatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_z_sparse_mat) :: a_glob + complex(psb_dpk_) :: b_glob(:) + integer :: ictxt + type(psb_z_sparse_mat) :: a + complex(psb_dpk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + ! local variables + logical :: use_parts, use_v + integer :: np, iam + integer :: length_row, i_count, j_count,& + & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + complex(psb_dpk_), allocatable :: val(:) + integer, parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=581 + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else + call psb_cdall(ictxt,desc_a,info,vg=v) + end if + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, length_row) + if (length_row == 1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + end if + else + length_row = 1 + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + if (length_row == 1) then + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return + +end subroutine zmatdist + diff --git a/util/psb_mat_dist_mod.f90 b/util/psb_mat_dist_mod.f90 index fbc97b6c..92675725 100644 --- a/util/psb_mat_dist_mod.f90 +++ b/util/psb_mat_dist_mod.f90 @@ -32,1789 +32,345 @@ module psb_mat_dist_mod interface psb_matdist - module procedure smatdist, cmatdist, dmatdist, zmatdist + subroutine smatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod, only : psb_s_sparse_mat, psb_desc_type, psb_spk_ + implicit none + + ! parameters + type(psb_s_sparse_mat) :: a_glob + real(psb_spk_) :: b_glob(:) + integer :: ictxt + type(psb_s_sparse_mat) :: a + real(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=*), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + end subroutine smatdist + subroutine dmatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod, only : psb_d_sparse_mat, psb_dpk_, psb_desc_type + implicit none + + ! parameters + type(psb_d_sparse_mat) :: a_glob + real(psb_dpk_) :: b_glob(:) + integer :: ictxt + type(psb_d_sparse_mat) :: a + real(psb_dpk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=*), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + end subroutine dmatdist + + subroutine cmatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod, only : psb_c_sparse_mat, psb_spk_, psb_desc_type + implicit none + + ! parameters + type(psb_c_sparse_mat) :: a_glob + complex(psb_spk_) :: b_glob(:) + integer :: ictxt + type(psb_c_sparse_mat) :: a + complex(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=*), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + end subroutine cmatdist + + subroutine zmatdist(a_glob, a, ictxt, desc_a,& + & b_glob, b, info, parts, v, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_sparse_mod, only : psb_z_sparse_mat, psb_dpk_, psb_desc_type + implicit none + + ! parameters + type(psb_z_sparse_mat) :: a_glob + complex(psb_dpk_) :: b_glob(:) + integer :: ictxt + type(psb_z_sparse_mat) :: a + complex(psb_dpk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=*), optional :: fmt + + integer :: v(:) + interface + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + optional :: parts, v + + + end subroutine zmatdist end interface -contains - - - subroutine smatdist(a_glob, a, ictxt, desc_a,& - & b_glob, b, info, parts, v, inroot,fmt) - ! - ! an utility subroutine to distribute a matrix among processors - ! according to a user defined data distribution, using - ! sparse matrix subroutines. - ! - ! type(d_spmat) :: a_glob - ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' - ! a%aspk for coefficient values - ! a%ia1 for column indices - ! a%ia2 for row pointers - ! a%m for number of global matrix rows - ! a%k for number of global matrix columns - ! on exit : undefined, with unassociated pointers. - ! - ! type(d_spmat) :: a - ! on entry: fresh variable. - ! on exit : this will contain the local sparse matrix. - ! - ! interface parts - ! ! .....user passed subroutine..... - ! subroutine parts(global_indx,n,np,pv,nv) - ! implicit none - ! integer, intent(in) :: global_indx, n, np - ! integer, intent(out) :: nv - ! integer, intent(out) :: pv(*) - ! - ! end subroutine parts - ! end interface - ! on entry: subroutine providing user defined data distribution. - ! for each global_indx the subroutine should return - ! the list pv of all processes owning the row with - ! that index; the list will contain nv entries. - ! usually nv=1; if nv >1 then we have an overlap in the data - ! distribution. - ! - ! integer :: ictxt - ! on entry: blacs context. - ! on exit : unchanged. - ! - ! type (desc_type) :: desc_a - ! on entry: fresh variable. - ! on exit : the updated array descriptor - ! - ! real(psb_dpk_), optional :: b_glob(:) - ! on entry: this contains right hand side. - ! on exit : - ! - ! real(psb_dpk_), allocatable, optional :: b(:) - ! on entry: fresh variable. - ! on exit : this will contain the local right hand side. - ! - ! integer, optional :: inroot - ! on entry: specifies processor holding a_glob. default: 0 - ! on exit : unchanged. - ! - use psb_sparse_mod - use psb_mat_mod - implicit none - - ! parameters - type(psb_s_sparse_mat) :: a_glob - real(psb_spk_) :: b_glob(:) - integer :: ictxt - type(psb_s_sparse_mat) :: a - real(psb_spk_), allocatable :: b(:) - type(psb_desc_type) :: desc_a - integer, intent(out) :: info - integer, optional :: inroot - character(len=5), optional :: fmt - - integer :: v(:) - interface - subroutine parts(global_indx,n,np,pv,nv) - implicit none - integer, intent(in) :: global_indx, n, np - integer, intent(out) :: nv - integer, intent(out) :: pv(*) - end subroutine parts - end interface - optional :: parts, v - - ! local variables - logical :: use_parts, use_v - integer :: np, iam - integer :: length_row, i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) - integer, allocatable :: iwork(:) - character :: afmt*5 - integer, allocatable :: irow(:),icol(:) - real(psb_spk_), allocatable :: val(:) - integer, parameter :: nb=30 - real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 - character(len=20) :: name, ch_err - - info = 0 - err = 0 - name = 'mat_distf' - call psb_erractionsave(err_act) - - ! executable statements - if (present(inroot)) then - root = inroot - else - root = psb_root_ - end if - call psb_info(ictxt, iam, np) - if (iam == root) then - nrow = a_glob%get_nrows() - ncol = a_glob%get_ncols() - if (nrow /= ncol) then - write(0,*) 'a rectangular matrix ? ',nrow,ncol - info=-1 - call psb_errpush(info,name) - goto 9999 - endif - nnzero = a_glob%get_nzeros() - nrhs = 1 - endif - - use_parts = present(parts) - use_v = present(v) - if (count((/ use_parts, use_v /)) /= 1) then - info=581 - call psb_errpush(info,name,a_err=" v, parts") - goto 9999 - endif - - ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) - liwork = max(np, nrow + ncol) - allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - endif - if (iam == root) then - write (*, fmt = *) 'start matdist',root, size(iwork),& - &nrow, ncol, nnzero,nrhs - endif - if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) - else - call psb_cdall(ictxt,desc_a,info,vg=v) - end if - if(info/=0) then - info=4010 - ch_err='psb_cdall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 - ch_err='psb_psspall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_psdsall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - - isize = 3*nb*max(((nnzero+nrow)/nrow),nb) - allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - i_count = 1 - - do while (i_count <= nrow) - - if (use_parts) then - call parts(i_count,nrow,np,iwork, length_row) - if (length_row == 1) then - j_count = i_count - iproc = iwork(1) - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - call parts(j_count,nrow,np,iwork, length_row) - if (length_row /= 1 ) exit - if (iwork(1) /= iproc ) exit - end do - end if - else - length_row = 1 - j_count = i_count - iproc = v(i_count) - - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - if (v(j_count) /= iproc ) exit - end do - end if - - if (length_row == 1) then - ! now we should insert rows i_count..j_count-1 - nnr = j_count - i_count - - if (iam == root) then - - ll = 0 - do i= i_count, j_count-1 - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (iproc == iam) then - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_spins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_ins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) - call psb_rcv(ictxt,ll,iproc) - endif - else if (iam /= root) then - - if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) - if (ll > size(irow)) then - write(0,*) iam,'need to reallocate ',ll - deallocate(val,irow,icol) - allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& - & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - - i_count = j_count - - else - - ! here processors are counted 1..np - do j_count = 1, length_row - k_count = iwork(j_count) - if (iam == root) then - - ll = 0 - do i= i_count, i_count - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (k_count == iam) then - - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,ll,k_count) - call psb_snd(ictxt,irow(1:ll),k_count) - call psb_snd(ictxt,icol(1:ll),k_count) - call psb_snd(ictxt,val(1:ll),k_count) - call psb_snd(ictxt,b_glob(i_count),k_count) - call psb_rcv(ictxt,ll,k_count) - endif - else if (iam /= root) then - if (k_count == iam) then - call psb_rcv(ictxt,ll,root) - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - end do - i_count = i_count + 1 - endif - end do - - if (present(fmt)) then - afmt=fmt - else - afmt = 'CSR' - endif - - call psb_barrier(ictxt) - t0 = psb_wtime() - call psb_cdasb(desc_a,info) - t1 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_cdasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_barrier(ictxt) - t2 = psb_wtime() - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) - t3 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_spasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - if (iam == root) then - write(*,*) 'descriptor assembly: ',t1-t0 - write(*,*) 'sparse matrix assembly: ',t3-t2 - end if - - call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 - ch_err='psdsasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - deallocate(iwork) - if (iam == root) write (*, fmt = *) 'end matdist' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - - end subroutine smatdist - - - subroutine dmatdist(a_glob, a, ictxt, desc_a,& - & b_glob, b, info, parts, v, inroot,fmt) - ! - ! an utility subroutine to distribute a matrix among processors - ! according to a user defined data distribution, using - ! sparse matrix subroutines. - ! - ! type(d_spmat) :: a_glob - ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' - ! a%aspk for coefficient values - ! a%ia1 for column indices - ! a%ia2 for row pointers - ! a%m for number of global matrix rows - ! a%k for number of global matrix columns - ! on exit : undefined, with unassociated pointers. - ! - ! type(d_spmat) :: a - ! on entry: fresh variable. - ! on exit : this will contain the local sparse matrix. - ! - ! interface parts - ! ! .....user passed subroutine..... - ! subroutine parts(global_indx,n,np,pv,nv) - ! implicit none - ! integer, intent(in) :: global_indx, n, np - ! integer, intent(out) :: nv - ! integer, intent(out) :: pv(*) - ! - ! end subroutine parts - ! end interface - ! on entry: subroutine providing user defined data distribution. - ! for each global_indx the subroutine should return - ! the list pv of all processes owning the row with - ! that index; the list will contain nv entries. - ! usually nv=1; if nv >1 then we have an overlap in the data - ! distribution. - ! - ! integer :: ictxt - ! on entry: blacs context. - ! on exit : unchanged. - ! - ! type (desc_type) :: desc_a - ! on entry: fresh variable. - ! on exit : the updated array descriptor - ! - ! real(psb_dpk_), optional :: b_glob(:) - ! on entry: this contains right hand side. - ! on exit : - ! - ! real(psb_dpk_), allocatable, optional :: b(:) - ! on entry: fresh variable. - ! on exit : this will contain the local right hand side. - ! - ! integer, optional :: inroot - ! on entry: specifies processor holding a_glob. default: 0 - ! on exit : unchanged. - ! - use psb_sparse_mod - use psb_mat_mod - implicit none - - ! parameters - type(psb_d_sparse_mat) :: a_glob - real(psb_dpk_) :: b_glob(:) - integer :: ictxt - type(psb_d_sparse_mat) :: a - real(psb_dpk_), allocatable :: b(:) - type(psb_desc_type) :: desc_a - integer, intent(out) :: info - integer, optional :: inroot - character(len=5), optional :: fmt - - integer :: v(:) - interface - subroutine parts(global_indx,n,np,pv,nv) - implicit none - integer, intent(in) :: global_indx, n, np - integer, intent(out) :: nv - integer, intent(out) :: pv(*) - end subroutine parts - end interface - optional :: parts, v - - ! local variables - logical :: use_parts, use_v - integer :: np, iam - integer :: length_row, i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) - integer, allocatable :: iwork(:) - character :: afmt*5 - integer, allocatable :: irow(:),icol(:) - real(psb_dpk_), allocatable :: val(:) - integer, parameter :: nb=30 - real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 - character(len=20) :: name, ch_err - - info = 0 - err = 0 - name = 'mat_distf' - call psb_erractionsave(err_act) - - ! executable statements - if (present(inroot)) then - root = inroot - else - root = psb_root_ - end if - call psb_info(ictxt, iam, np) - if (iam == root) then - nrow = a_glob%get_nrows() - ncol = a_glob%get_ncols() - if (nrow /= ncol) then - write(0,*) 'a rectangular matrix ? ',nrow,ncol - info=-1 - call psb_errpush(info,name) - goto 9999 - endif - nnzero = a_glob%get_nzeros() - nrhs = 1 - endif - - use_parts = present(parts) - use_v = present(v) - if (count((/ use_parts, use_v /)) /= 1) then - info=581 - call psb_errpush(info,name,a_err=" v, parts") - goto 9999 - endif - - ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) - liwork = max(np, nrow + ncol) - allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - endif - if (iam == root) then - write (*, fmt = *) 'start matdist',root, size(iwork),& - &nrow, ncol, nnzero,nrhs - endif - if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) - else - call psb_cdall(ictxt,desc_a,info,vg=v) - end if - if(info/=0) then - info=4010 - ch_err='psb_cdall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 - ch_err='psb_psspall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_psdsall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - - isize = 3*nb*max(((nnzero+nrow)/nrow),nb) - allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - i_count = 1 - - do while (i_count <= nrow) - - if (use_parts) then - call parts(i_count,nrow,np,iwork, length_row) - if (length_row == 1) then - j_count = i_count - iproc = iwork(1) - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - call parts(j_count,nrow,np,iwork, length_row) - if (length_row /= 1 ) exit - if (iwork(1) /= iproc ) exit - end do - end if - else - length_row = 1 - j_count = i_count - iproc = v(i_count) - - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - if (v(j_count) /= iproc ) exit - end do - end if - - if (length_row == 1) then - ! now we should insert rows i_count..j_count-1 - nnr = j_count - i_count - - if (iam == root) then - - ll = 0 - do i= i_count, j_count-1 - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (iproc == iam) then - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_spins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_ins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) - call psb_rcv(ictxt,ll,iproc) - endif - else if (iam /= root) then - - if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) - if (ll > size(irow)) then - write(0,*) iam,'need to reallocate ',ll - deallocate(val,irow,icol) - allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& - & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - - i_count = j_count - - else - - ! here processors are counted 1..np - do j_count = 1, length_row - k_count = iwork(j_count) - if (iam == root) then - - ll = 0 - do i= i_count, i_count - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (k_count == iam) then - - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,ll,k_count) - call psb_snd(ictxt,irow(1:ll),k_count) - call psb_snd(ictxt,icol(1:ll),k_count) - call psb_snd(ictxt,val(1:ll),k_count) - call psb_snd(ictxt,b_glob(i_count),k_count) - call psb_rcv(ictxt,ll,k_count) - endif - else if (iam /= root) then - if (k_count == iam) then - call psb_rcv(ictxt,ll,root) - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - end do - i_count = i_count + 1 - endif - end do - - if (present(fmt)) then - afmt=fmt - else - afmt = 'CSR' - endif - - call psb_barrier(ictxt) - t0 = psb_wtime() - call psb_cdasb(desc_a,info) - t1 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_cdasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_barrier(ictxt) - t2 = psb_wtime() - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) - t3 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_spasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - if (iam == root) then - write(*,*) 'descriptor assembly: ',t1-t0 - write(*,*) 'sparse matrix assembly: ',t3-t2 - end if - - call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 - ch_err='psdsasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - deallocate(iwork) - if (iam == root) write (*, fmt = *) 'end matdist' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - - end subroutine dmatdist - - - subroutine cmatdist(a_glob, a, ictxt, desc_a,& - & b_glob, b, info, parts, v, inroot,fmt) - ! - ! an utility subroutine to distribute a matrix among processors - ! according to a user defined data distribution, using - ! sparse matrix subroutines. - ! - ! type(d_spmat) :: a_glob - ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' - ! a%aspk for coefficient values - ! a%ia1 for column indices - ! a%ia2 for row pointers - ! a%m for number of global matrix rows - ! a%k for number of global matrix columns - ! on exit : undefined, with unassociated pointers. - ! - ! type(d_spmat) :: a - ! on entry: fresh variable. - ! on exit : this will contain the local sparse matrix. - ! - ! interface parts - ! ! .....user passed subroutine..... - ! subroutine parts(global_indx,n,np,pv,nv) - ! implicit none - ! integer, intent(in) :: global_indx, n, np - ! integer, intent(out) :: nv - ! integer, intent(out) :: pv(*) - ! - ! end subroutine parts - ! end interface - ! on entry: subroutine providing user defined data distribution. - ! for each global_indx the subroutine should return - ! the list pv of all processes owning the row with - ! that index; the list will contain nv entries. - ! usually nv=1; if nv >1 then we have an overlap in the data - ! distribution. - ! - ! integer :: ictxt - ! on entry: blacs context. - ! on exit : unchanged. - ! - ! type (desc_type) :: desc_a - ! on entry: fresh variable. - ! on exit : the updated array descriptor - ! - ! real(psb_dpk_), optional :: b_glob(:) - ! on entry: this contains right hand side. - ! on exit : - ! - ! real(psb_dpk_), allocatable, optional :: b(:) - ! on entry: fresh variable. - ! on exit : this will contain the local right hand side. - ! - ! integer, optional :: inroot - ! on entry: specifies processor holding a_glob. default: 0 - ! on exit : unchanged. - ! - use psb_sparse_mod - use psb_mat_mod - implicit none - - ! parameters - type(psb_c_sparse_mat) :: a_glob - complex(psb_spk_) :: b_glob(:) - integer :: ictxt - type(psb_c_sparse_mat) :: a - complex(psb_spk_), allocatable :: b(:) - type(psb_desc_type) :: desc_a - integer, intent(out) :: info - integer, optional :: inroot - character(len=5), optional :: fmt - - integer :: v(:) - interface - subroutine parts(global_indx,n,np,pv,nv) - implicit none - integer, intent(in) :: global_indx, n, np - integer, intent(out) :: nv - integer, intent(out) :: pv(*) - end subroutine parts - end interface - optional :: parts, v - - ! local variables - logical :: use_parts, use_v - integer :: np, iam - integer :: length_row, i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) - integer, allocatable :: iwork(:) - character :: afmt*5 - integer, allocatable :: irow(:),icol(:) - complex(psb_spk_), allocatable :: val(:) - integer, parameter :: nb=30 - real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 - character(len=20) :: name, ch_err - - info = 0 - err = 0 - name = 'mat_distf' - call psb_erractionsave(err_act) - - ! executable statements - if (present(inroot)) then - root = inroot - else - root = psb_root_ - end if - call psb_info(ictxt, iam, np) - if (iam == root) then - nrow = a_glob%get_nrows() - ncol = a_glob%get_ncols() - if (nrow /= ncol) then - write(0,*) 'a rectangular matrix ? ',nrow,ncol - info=-1 - call psb_errpush(info,name) - goto 9999 - endif - nnzero = a_glob%get_nzeros() - nrhs = 1 - endif - - use_parts = present(parts) - use_v = present(v) - if (count((/ use_parts, use_v /)) /= 1) then - info=581 - call psb_errpush(info,name,a_err=" v, parts") - goto 9999 - endif - - ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) - liwork = max(np, nrow + ncol) - allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - endif - if (iam == root) then - write (*, fmt = *) 'start matdist',root, size(iwork),& - &nrow, ncol, nnzero,nrhs - endif - if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) - else - call psb_cdall(ictxt,desc_a,info,vg=v) - end if - if(info/=0) then - info=4010 - ch_err='psb_cdall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 - ch_err='psb_psspall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_psdsall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - - isize = 3*nb*max(((nnzero+nrow)/nrow),nb) - allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - i_count = 1 - - do while (i_count <= nrow) - - if (use_parts) then - call parts(i_count,nrow,np,iwork, length_row) - if (length_row == 1) then - j_count = i_count - iproc = iwork(1) - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - call parts(j_count,nrow,np,iwork, length_row) - if (length_row /= 1 ) exit - if (iwork(1) /= iproc ) exit - end do - end if - else - length_row = 1 - j_count = i_count - iproc = v(i_count) - - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - if (v(j_count) /= iproc ) exit - end do - end if - - if (length_row == 1) then - ! now we should insert rows i_count..j_count-1 - nnr = j_count - i_count - - if (iam == root) then - - ll = 0 - do i= i_count, j_count-1 - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (iproc == iam) then - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_spins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_ins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) - call psb_rcv(ictxt,ll,iproc) - endif - else if (iam /= root) then - - if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) - if (ll > size(irow)) then - write(0,*) iam,'need to reallocate ',ll - deallocate(val,irow,icol) - allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& - & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - - i_count = j_count - - else - - ! here processors are counted 1..np - do j_count = 1, length_row - k_count = iwork(j_count) - if (iam == root) then - - ll = 0 - do i= i_count, i_count - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (k_count == iam) then - - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,ll,k_count) - call psb_snd(ictxt,irow(1:ll),k_count) - call psb_snd(ictxt,icol(1:ll),k_count) - call psb_snd(ictxt,val(1:ll),k_count) - call psb_snd(ictxt,b_glob(i_count),k_count) - call psb_rcv(ictxt,ll,k_count) - endif - else if (iam /= root) then - if (k_count == iam) then - call psb_rcv(ictxt,ll,root) - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - end do - i_count = i_count + 1 - endif - end do - - if (present(fmt)) then - afmt=fmt - else - afmt = 'CSR' - endif - - call psb_barrier(ictxt) - t0 = psb_wtime() - call psb_cdasb(desc_a,info) - t1 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_cdasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_barrier(ictxt) - t2 = psb_wtime() - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) - t3 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_spasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - if (iam == root) then - write(*,*) 'descriptor assembly: ',t1-t0 - write(*,*) 'sparse matrix assembly: ',t3-t2 - end if - - call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 - ch_err='psdsasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - deallocate(iwork) - if (iam == root) write (*, fmt = *) 'end matdist' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - - end subroutine cmatdist - - - subroutine zmatdist(a_glob, a, ictxt, desc_a,& - & b_glob, b, info, parts, v, inroot,fmt) - ! - ! an utility subroutine to distribute a matrix among processors - ! according to a user defined data distribution, using - ! sparse matrix subroutines. - ! - ! type(d_spmat) :: a_glob - ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' - ! a%aspk for coefficient values - ! a%ia1 for column indices - ! a%ia2 for row pointers - ! a%m for number of global matrix rows - ! a%k for number of global matrix columns - ! on exit : undefined, with unassociated pointers. - ! - ! type(d_spmat) :: a - ! on entry: fresh variable. - ! on exit : this will contain the local sparse matrix. - ! - ! interface parts - ! ! .....user passed subroutine..... - ! subroutine parts(global_indx,n,np,pv,nv) - ! implicit none - ! integer, intent(in) :: global_indx, n, np - ! integer, intent(out) :: nv - ! integer, intent(out) :: pv(*) - ! - ! end subroutine parts - ! end interface - ! on entry: subroutine providing user defined data distribution. - ! for each global_indx the subroutine should return - ! the list pv of all processes owning the row with - ! that index; the list will contain nv entries. - ! usually nv=1; if nv >1 then we have an overlap in the data - ! distribution. - ! - ! integer :: ictxt - ! on entry: blacs context. - ! on exit : unchanged. - ! - ! type (desc_type) :: desc_a - ! on entry: fresh variable. - ! on exit : the updated array descriptor - ! - ! real(psb_dpk_), optional :: b_glob(:) - ! on entry: this contains right hand side. - ! on exit : - ! - ! real(psb_dpk_), allocatable, optional :: b(:) - ! on entry: fresh variable. - ! on exit : this will contain the local right hand side. - ! - ! integer, optional :: inroot - ! on entry: specifies processor holding a_glob. default: 0 - ! on exit : unchanged. - ! - use psb_sparse_mod - use psb_mat_mod - implicit none - - ! parameters - type(psb_z_sparse_mat) :: a_glob - complex(psb_dpk_) :: b_glob(:) - integer :: ictxt - type(psb_z_sparse_mat) :: a - complex(psb_dpk_), allocatable :: b(:) - type(psb_desc_type) :: desc_a - integer, intent(out) :: info - integer, optional :: inroot - character(len=5), optional :: fmt - - integer :: v(:) - interface - subroutine parts(global_indx,n,np,pv,nv) - implicit none - integer, intent(in) :: global_indx, n, np - integer, intent(out) :: nv - integer, intent(out) :: pv(*) - end subroutine parts - end interface - optional :: parts, v - - ! local variables - logical :: use_parts, use_v - integer :: np, iam - integer :: length_row, i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) - integer, allocatable :: iwork(:) - character :: afmt*5 - integer, allocatable :: irow(:),icol(:) - complex(psb_dpk_), allocatable :: val(:) - integer, parameter :: nb=30 - real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 - character(len=20) :: name, ch_err - - info = 0 - err = 0 - name = 'mat_distf' - call psb_erractionsave(err_act) - - ! executable statements - if (present(inroot)) then - root = inroot - else - root = psb_root_ - end if - call psb_info(ictxt, iam, np) - if (iam == root) then - nrow = a_glob%get_nrows() - ncol = a_glob%get_ncols() - if (nrow /= ncol) then - write(0,*) 'a rectangular matrix ? ',nrow,ncol - info=-1 - call psb_errpush(info,name) - goto 9999 - endif - nnzero = a_glob%get_nzeros() - nrhs = 1 - endif - - use_parts = present(parts) - use_v = present(v) - if (count((/ use_parts, use_v /)) /= 1) then - info=581 - call psb_errpush(info,name,a_err=" v, parts") - goto 9999 - endif - - ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) - liwork = max(np, nrow + ncol) - allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - endif - if (iam == root) then - write (*, fmt = *) 'start matdist',root, size(iwork),& - &nrow, ncol, nnzero,nrhs - endif - if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) - else - call psb_cdall(ictxt,desc_a,info,vg=v) - end if - if(info/=0) then - info=4010 - ch_err='psb_cdall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 - ch_err='psb_psspall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_psdsall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - - isize = 3*nb*max(((nnzero+nrow)/nrow),nb) - allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - i_count = 1 - - do while (i_count <= nrow) - - if (use_parts) then - call parts(i_count,nrow,np,iwork, length_row) - if (length_row == 1) then - j_count = i_count - iproc = iwork(1) - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - call parts(j_count,nrow,np,iwork, length_row) - if (length_row /= 1 ) exit - if (iwork(1) /= iproc ) exit - end do - end if - else - length_row = 1 - j_count = i_count - iproc = v(i_count) - - do - j_count = j_count + 1 - if (j_count-i_count >= nb) exit - if (j_count > nrow) exit - if (v(j_count) /= iproc ) exit - end do - end if - - if (length_row == 1) then - ! now we should insert rows i_count..j_count-1 - nnr = j_count - i_count - - if (iam == root) then - - ll = 0 - do i= i_count, j_count-1 - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (iproc == iam) then - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_spins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psb_ins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) - call psb_rcv(ictxt,ll,iproc) - endif - else if (iam /= root) then - - if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) - if (ll > size(irow)) then - write(0,*) iam,'need to reallocate ',ll - deallocate(val,irow,icol) - allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& - & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - - i_count = j_count - - else - - ! here processors are counted 1..np - do j_count = 1, length_row - k_count = iwork(j_count) - if (iam == root) then - - ll = 0 - do i= i_count, i_count - call a_glob%csget(i,i,nz,& - & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then - if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then - write(0,*) 'Allocation failure? This should not happen!' - end if - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ll = ll + nz - end do - - if (k_count == iam) then - - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - else - call psb_snd(ictxt,ll,k_count) - call psb_snd(ictxt,irow(1:ll),k_count) - call psb_snd(ictxt,icol(1:ll),k_count) - call psb_snd(ictxt,val(1:ll),k_count) - call psb_snd(ictxt,b_glob(i_count),k_count) - call psb_rcv(ictxt,ll,k_count) - endif - else if (iam /= root) then - if (k_count == iam) then - call psb_rcv(ictxt,ll,root) - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_rcv(ictxt,b_glob(i_count),root) - call psb_snd(ictxt,ll,root) - call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psspins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& - & b,desc_a,info) - if(info/=0) then - info=4010 - ch_err='psdsins' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - endif - endif - end do - i_count = i_count + 1 - endif - end do - - if (present(fmt)) then - afmt=fmt - else - afmt = 'CSR' - endif - - call psb_barrier(ictxt) - t0 = psb_wtime() - call psb_cdasb(desc_a,info) - t1 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_cdasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_barrier(ictxt) - t2 = psb_wtime() - call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) - t3 = psb_wtime() - if(info/=0)then - info=4010 - ch_err='psb_spasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - if (iam == root) then - write(*,*) 'descriptor assembly: ',t1-t0 - write(*,*) 'sparse matrix assembly: ',t3-t2 - end if - - call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 - ch_err='psdsasb' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - deallocate(iwork) - if (iam == root) write (*, fmt = *) 'end matdist' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - - end subroutine zmatdist - end module psb_mat_dist_mod diff --git a/util/psb_mmio_impl.f90 b/util/psb_mmio_impl.f90 new file mode 100644 index 00000000..81f85066 --- /dev/null +++ b/util/psb_mmio_impl.f90 @@ -0,0 +1,1423 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine mm_svet_read(b, info, iunit, filename) + use psb_sparse_mod + implicit none + real(psb_spk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j,infile + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + + info = 0 + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym + + if ( (object /= 'matrix').or.(fmt /= 'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + info = -3 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) + + end if ! read right hand sides + + if (infile/=5) close(infile) + + return + ! open failed +901 write(0,*) 'mm_vet_read: could not open file ',& + & infile,' for input' + info = -1 + return + +902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& + & ' during input' + info = -2 + return +993 write(0,*) 'mm_vet_read: memory allocation failure' + info = -3 + return +end subroutine mm_svet_read + + +subroutine mm_dvet_read(b, info, iunit, filename) + use psb_sparse_mod + implicit none + real(psb_dpk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, infile + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + + info = 0 + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym + + if ( (object /= 'matrix').or.(fmt /= 'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + info = -3 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) + + end if ! read right hand sides + if (infile/=5) close(infile) + + return + ! open failed +901 write(0,*) 'mm_vet_read: could not open file ',& + & infile,' for input' + info = -1 + return + +902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& + & ' during input' + info = -2 + return +993 write(0,*) 'mm_vet_read: memory allocation failure' + info = -3 + return +end subroutine mm_dvet_read + + +subroutine mm_cvet_read(b, info, iunit, filename) + use psb_sparse_mod + implicit none + complex(psb_spk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j,infile + real(psb_spk_) :: bre, bim + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + + info = 0 + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym + + if ( (object /= 'matrix').or.(fmt /= 'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + info = -3 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + do j=1, ncol + do i=1, nrow + read(infile,fmt=*,end=902) bre,bim + b(i,j) = cmplx(bre,bim,kind=psb_spk_) + end do + end do + + end if ! read right hand sides + if (infile/=5) close(infile) + + return + ! open failed +901 write(0,*) 'mm_vet_read: could not open file ',& + & infile,' for input' + info = -1 + return + +902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& + & ' during input' + info = -2 + return +993 write(0,*) 'mm_vet_read: memory allocation failure' + info = -3 + return +end subroutine mm_cvet_read + + +subroutine mm_zvet_read(b, info, iunit, filename) + use psb_sparse_mod + implicit none + complex(psb_dpk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j,infile + real(psb_dpk_) :: bre, bim + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + + info = 0 + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym + + if ( (object /= 'matrix').or.(fmt /= 'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + info = -3 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + do j=1, ncol + do i=1, nrow + read(infile,fmt=*,end=902) bre,bim + b(i,j) = cmplx(bre,bim,kind=psb_dpk_) + end do + end do + + end if ! read right hand sides + if (infile/=5) close(infile) + + return + ! open failed +901 write(0,*) 'mm_vet_read: could not open file ',& + & infile,' for input' + info = -1 + return + +902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& + & ' during input' + info = -2 + return +993 write(0,*) 'mm_vet_read: memory allocation failure' + info = -3 + return +end subroutine mm_zvet_read + +subroutine mm_svet2_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + real(psb_spk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_svet2_write + +subroutine mm_svet1_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + real(psb_spk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_svet1_write + + +subroutine mm_dvet2_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + real(psb_dpk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_dvet2_write + +subroutine mm_dvet1_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + real(psb_dpk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_dvet1_write + + +subroutine mm_cvet2_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + complex(psb_spk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_cvet2_write + +subroutine mm_cvet1_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + complex(psb_spk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_cvet1_write + +subroutine mm_zvet2_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + complex(psb_dpk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_zvet2_write + +subroutine mm_zvet1_write(b, header, info, iunit, filename) + use psb_sparse_mod + implicit none + complex(psb_dpk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + +end subroutine mm_zvet1_write + + +subroutine smm_mat_read(a, info, iunit, filename) + use psb_sparse_mod + implicit none + type(psb_s_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero + integer :: ircode, i,nzr,infile + type(psb_s_coo_sparse_mat), allocatable :: acoo + + info = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(0,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + + + if (infile/=5) close(infile) + return + + ! open failed +901 info=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 info=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine smm_mat_read + + +subroutine smm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod + implicit none + type(psb_s_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: iout + + + info = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(0,*) 'Error while opening ',filename + return +end subroutine smm_mat_write + +subroutine dmm_mat_read(a, info, iunit, filename) + use psb_sparse_mod + implicit none + type(psb_d_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero + integer :: ircode, i,nzr,infile + type(psb_d_coo_sparse_mat), allocatable :: acoo + + info = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(0,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 info=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 info=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine dmm_mat_read + + +subroutine dmm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod + implicit none + type(psb_d_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: iout + + + info = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(0,*) 'Error while opening ',filename + return +end subroutine dmm_mat_write + +subroutine cmm_mat_read(a, info, iunit, filename) + use psb_sparse_mod + implicit none + type(psb_c_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero + integer :: ircode, i,nzr,infile + type(psb_c_coo_sparse_mat), allocatable :: acoo + real(psb_spk_) :: are, aim + info = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_spk_) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_spk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_spk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(0,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 info=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 info=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine cmm_mat_read + + +subroutine cmm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod + implicit none + type(psb_c_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: iout + + + info = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(0,*) 'Error while opening ',filename + return +end subroutine cmm_mat_write + +subroutine zmm_mat_read(a, info, iunit, filename) + use psb_sparse_mod + implicit none + type(psb_z_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero + integer :: ircode, i,nzr,infile + type(psb_z_coo_sparse_mat), allocatable :: acoo + real(psb_dpk_) :: are, aim + info = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(0,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 info=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 info=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine zmm_mat_read + + +subroutine zmm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod + implicit none + type(psb_z_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: iout + + + info = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(0,*) 'Error while opening ',filename + return +end subroutine zmm_mat_write + + diff --git a/util/psb_mmio_mod.f90 b/util/psb_mmio_mod.f90 index a9a9e38b..c7bf00c7 100644 --- a/util/psb_mmio_mod.f90 +++ b/util/psb_mmio_mod.f90 @@ -33,1415 +33,190 @@ module psb_mmio_mod public mm_mat_read, mm_mat_write, mm_vet_read, mm_vet_write - interface mm_mat_read - module procedure smm_mat_read, dmm_mat_read, cmm_mat_read, zmm_mat_read - end interface - - interface mm_mat_write - module procedure smm_mat_write, dmm_mat_write, cmm_mat_write, zmm_mat_write - end interface - interface mm_vet_read - module procedure mm_svet_read, mm_dvet_read, mm_cvet_read, mm_zvet_read - end interface - interface mm_vet_write - module procedure mm_svet2_write, mm_svet1_write, mm_dvet2_write, mm_dvet1_write,& - & mm_cvet2_write, mm_cvet1_write, mm_zvet2_write, mm_zvet1_write + subroutine mm_svet_read(b, info, iunit, filename) + use psb_sparse_mod, only : psb_spk_ + implicit none + real(psb_spk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_svet_read + subroutine mm_dvet_read(b, info, iunit, filename) + use psb_sparse_mod, only : psb_dpk_ + implicit none + real(psb_dpk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_dvet_read + subroutine mm_cvet_read(b, info, iunit, filename) + use psb_sparse_mod, only : psb_spk_ + implicit none + complex(psb_spk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_cvet_read + subroutine mm_zvet_read(b, info, iunit, filename) + use psb_sparse_mod, only : psb_dpk_ + implicit none + complex(psb_dpk_), allocatable, intent(out) :: b(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_zvet_read end interface -contains - - subroutine mm_svet_read(b, info, iunit, filename) - use psb_sparse_mod - implicit none - real(psb_spk_), allocatable, intent(out) :: b(:,:) - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j,infile - character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& - & line*1024 - - info = 0 - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym - - if ( (object /= 'matrix').or.(fmt /= 'array')) then - write(0,*) 'read_rhs: input file type not yet supported' - info = -3 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - - read(line,fmt=*)nrow,ncol - - if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then - allocate(b(nrow,ncol),stat = ircode) - if (ircode /= 0) goto 993 - read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) - - end if ! read right hand sides - - if (infile/=5) close(infile) - - return - ! open failed -901 write(0,*) 'mm_vet_read: could not open file ',& - & infile,' for input' - info = -1 - return - -902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& - & ' during input' - info = -2 - return -993 write(0,*) 'mm_vet_read: memory allocation failure' - info = -3 - return - end subroutine mm_svet_read - - - subroutine mm_dvet_read(b, info, iunit, filename) - use psb_sparse_mod - implicit none - real(psb_dpk_), allocatable, intent(out) :: b(:,:) - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, infile - character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& - & line*1024 - - info = 0 - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym - - if ( (object /= 'matrix').or.(fmt /= 'array')) then - write(0,*) 'read_rhs: input file type not yet supported' - info = -3 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - - read(line,fmt=*)nrow,ncol - - if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then - allocate(b(nrow,ncol),stat = ircode) - if (ircode /= 0) goto 993 - read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) - - end if ! read right hand sides - if (infile/=5) close(infile) - - return - ! open failed -901 write(0,*) 'mm_vet_read: could not open file ',& - & infile,' for input' - info = -1 - return - -902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& - & ' during input' - info = -2 - return -993 write(0,*) 'mm_vet_read: memory allocation failure' - info = -3 - return - end subroutine mm_dvet_read - - - subroutine mm_cvet_read(b, info, iunit, filename) - use psb_sparse_mod - implicit none - complex(psb_spk_), allocatable, intent(out) :: b(:,:) - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j,infile - real(psb_spk_) :: bre, bim - character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& - & line*1024 - - info = 0 - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym - - if ( (object /= 'matrix').or.(fmt /= 'array')) then - write(0,*) 'read_rhs: input file type not yet supported' - info = -3 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - - read(line,fmt=*)nrow,ncol - - if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then - allocate(b(nrow,ncol),stat = ircode) - if (ircode /= 0) goto 993 - do j=1, ncol - do i=1, nrow - read(infile,fmt=*,end=902) bre,bim - b(i,j) = cmplx(bre,bim,kind=psb_spk_) - end do - end do - - end if ! read right hand sides - if (infile/=5) close(infile) - - return - ! open failed -901 write(0,*) 'mm_vet_read: could not open file ',& - & infile,' for input' - info = -1 - return - -902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& - & ' during input' - info = -2 - return -993 write(0,*) 'mm_vet_read: memory allocation failure' - info = -3 - return - end subroutine mm_cvet_read - - - subroutine mm_zvet_read(b, info, iunit, filename) - use psb_sparse_mod - implicit none - complex(psb_dpk_), allocatable, intent(out) :: b(:,:) - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j,infile - real(psb_dpk_) :: bre, bim - character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& - & line*1024 - - info = 0 - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym - - if ( (object /= 'matrix').or.(fmt /= 'array')) then - write(0,*) 'read_rhs: input file type not yet supported' - info = -3 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - - read(line,fmt=*)nrow,ncol - - if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then - allocate(b(nrow,ncol),stat = ircode) - if (ircode /= 0) goto 993 - do j=1, ncol - do i=1, nrow - read(infile,fmt=*,end=902) bre,bim - b(i,j) = cmplx(bre,bim,kind=psb_dpk_) - end do - end do - - end if ! read right hand sides - if (infile/=5) close(infile) - - return - ! open failed -901 write(0,*) 'mm_vet_read: could not open file ',& - & infile,' for input' - info = -1 - return - -902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,& - & ' during input' - info = -2 - return -993 write(0,*) 'mm_vet_read: memory allocation failure' - info = -3 - return - end subroutine mm_zvet_read - - subroutine mm_svet2_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - real(psb_spk_), intent(in) :: b(:,:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = size(b,2) - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i,1:ncol) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_svet2_write - - subroutine mm_svet1_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - real(psb_spk_), intent(in) :: b(:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = 1 - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_svet1_write - - - subroutine mm_dvet2_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - real(psb_dpk_), intent(in) :: b(:,:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = size(b,2) - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i,1:ncol) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_dvet2_write - - subroutine mm_dvet1_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - real(psb_dpk_), intent(in) :: b(:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = 1 - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_dvet1_write - - - subroutine mm_cvet2_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - complex(psb_spk_), intent(in) :: b(:,:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = size(b,2) - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i,1:ncol) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_cvet2_write - - subroutine mm_cvet1_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - complex(psb_spk_), intent(in) :: b(:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = 1 - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_cvet1_write - - subroutine mm_zvet2_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - complex(psb_dpk_), intent(in) :: b(:,:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = size(b,2) - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i,1:ncol) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_zvet2_write - - subroutine mm_zvet1_write(b, header, info, iunit, filename) - use psb_sparse_mod - implicit none - complex(psb_dpk_), intent(in) :: b(:) - character(len=*), intent(in) :: header - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: nrow, ncol, i,root, np, me, ircode, j, outfile - - character(len=80) :: frmtv - - info = 0 - if (present(filename)) then - if (filename=='-') then - outfile=6 - else - if (present(iunit)) then - outfile=iunit - else - outfile=99 - endif - open(outfile,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - outfile=iunit - else - outfile=6 - endif - endif - - write(outfile,'(a)') '%%MatrixMarket matrix array real general' - write(outfile,'(a)') '% '//trim(header) - write(outfile,'(a)') '% ' - nrow = size(b,1) - ncol = 1 - write(outfile,*) nrow,ncol - - write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' - - do i=1,size(b,1) - write(outfile,frmtv) b(i) - end do - - if (outfile /= 6) close(outfile) - - return - ! open failed -901 write(0,*) 'mm_vet_write: could not open file ',& - & outfile,' for output' - info = -1 - return - - end subroutine mm_zvet1_write - - - subroutine smm_mat_read(a, info, iunit, filename) - use psb_sparse_mod - implicit none - type(psb_s_sparse_mat), intent(out) :: a - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character :: mmheader*15, fmt*15, object*10, type*10, sym*15 - character(1024) :: line - integer :: nrow, ncol, nnzero - integer :: ircode, i,nzr,infile - type(psb_s_coo_sparse_mat), allocatable :: acoo - - info = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then - write(0,*) 'READ_MATRIX: input file type not yet supported' - info=909 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - read(line,fmt=*) nrow,ncol,nnzero - - allocate(acoo, stat=ircode) - if (ircode /= 0) goto 993 - if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then - call acoo%allocate(nrow,ncol,nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) - end do - call acoo%set_nzeros(nnzero) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - call acoo%allocate(nrow,ncol,2*nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) - end do - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else - write(0,*) 'read_matrix: matrix type not yet supported' - info=904 - end if - - - if (infile/=5) close(infile) - return - - ! open failed -901 info=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 info=902 - write(0,*) 'READ_MATRIX: Unexpected end of file ' - return -993 info=993 - write(0,*) 'READ_MATRIX: Memory allocation failure' - return - end subroutine smm_mat_read - - - subroutine smm_mat_write(a,mtitle,info,iunit,filename) - use psb_sparse_mod - implicit none - type(psb_s_sparse_mat), intent(in) :: a - integer, intent(out) :: info - character(len=*), intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: iout - - - info = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - call a%print(iout,head=mtitle) - - if (iout /= 6) close(iout) - - - return - -901 continue - info=901 - write(0,*) 'Error while opening ',filename - return - end subroutine smm_mat_write - - subroutine dmm_mat_read(a, info, iunit, filename) - use psb_sparse_mod - implicit none - type(psb_d_sparse_mat), intent(out) :: a - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character :: mmheader*15, fmt*15, object*10, type*10, sym*15 - character(1024) :: line - integer :: nrow, ncol, nnzero - integer :: ircode, i,nzr,infile - type(psb_d_coo_sparse_mat), allocatable :: acoo - - info = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then - write(0,*) 'READ_MATRIX: input file type not yet supported' - info=909 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - read(line,fmt=*) nrow,ncol,nnzero - - allocate(acoo, stat=ircode) - if (ircode /= 0) goto 993 - if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then - call acoo%allocate(nrow,ncol,nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) - end do - call acoo%set_nzeros(nnzero) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - call acoo%allocate(nrow,ncol,2*nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i) - end do - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else - write(0,*) 'read_matrix: matrix type not yet supported' - info=904 - end if - if (infile/=5) close(infile) - return - - ! open failed -901 info=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 info=902 - write(0,*) 'READ_MATRIX: Unexpected end of file ' - return -993 info=993 - write(0,*) 'READ_MATRIX: Memory allocation failure' - return - end subroutine dmm_mat_read - - - subroutine dmm_mat_write(a,mtitle,info,iunit,filename) - use psb_sparse_mod - implicit none - type(psb_d_sparse_mat), intent(in) :: a - integer, intent(out) :: info - character(len=*), intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: iout - - - info = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - call a%print(iout,head=mtitle) - - if (iout /= 6) close(iout) - - - return - -901 continue - info=901 - write(0,*) 'Error while opening ',filename - return - end subroutine dmm_mat_write - - subroutine cmm_mat_read(a, info, iunit, filename) - use psb_sparse_mod - implicit none - type(psb_c_sparse_mat), intent(out) :: a - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character :: mmheader*15, fmt*15, object*10, type*10, sym*15 - character(1024) :: line - integer :: nrow, ncol, nnzero - integer :: ircode, i,nzr,infile - type(psb_c_coo_sparse_mat), allocatable :: acoo - real(psb_spk_) :: are, aim - info = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then - write(0,*) 'READ_MATRIX: input file type not yet supported' - info=909 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - read(line,fmt=*) nrow,ncol,nnzero - - allocate(acoo, stat=ircode) - if (ircode /= 0) goto 993 - if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then - call acoo%allocate(nrow,ncol,nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim - acoo%val(i) = cmplx(are,aim,kind=psb_spk_) - end do - call acoo%set_nzeros(nnzero) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - call acoo%allocate(nrow,ncol,2*nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim - acoo%val(i) = cmplx(are,aim,kind=psb_spk_) - end do - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - call acoo%allocate(nrow,ncol,2*nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim - acoo%val(i) = cmplx(are,aim,kind=psb_spk_) - end do - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = conjg(acoo%val(i)) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else - write(0,*) 'read_matrix: matrix type not yet supported' - info=904 - end if - if (infile/=5) close(infile) - return - - ! open failed -901 info=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 info=902 - write(0,*) 'READ_MATRIX: Unexpected end of file ' - return -993 info=993 - write(0,*) 'READ_MATRIX: Memory allocation failure' - return - end subroutine cmm_mat_read - - - subroutine cmm_mat_write(a,mtitle,info,iunit,filename) - use psb_sparse_mod - implicit none - type(psb_c_sparse_mat), intent(in) :: a - integer, intent(out) :: info - character(len=*), intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: iout - - - info = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - call a%print(iout,head=mtitle) - - if (iout /= 6) close(iout) - - - return - -901 continue - info=901 - write(0,*) 'Error while opening ',filename - return - end subroutine cmm_mat_write - - subroutine zmm_mat_read(a, info, iunit, filename) - use psb_sparse_mod - implicit none - type(psb_z_sparse_mat), intent(out) :: a - integer, intent(out) :: info - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - character :: mmheader*15, fmt*15, object*10, type*10, sym*15 - character(1024) :: line - integer :: nrow, ncol, nnzero - integer :: ircode, i,nzr,infile - type(psb_z_coo_sparse_mat), allocatable :: acoo - real(psb_dpk_) :: are, aim - info = 0 - - if (present(filename)) then - if (filename=='-') then - infile=5 - else - if (present(iunit)) then - infile=iunit - else - infile=99 - endif - open(infile,file=filename, status='OLD', err=901, action='READ') - endif - else - if (present(iunit)) then - infile=iunit - else - infile=5 - endif - endif - - read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then - write(0,*) 'READ_MATRIX: input file type not yet supported' - info=909 - return - end if - - do - read(infile,fmt='(a)') line - if (line(1:1) /= '%') exit - end do - read(line,fmt=*) nrow,ncol,nnzero - - allocate(acoo, stat=ircode) - if (ircode /= 0) goto 993 - if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then - call acoo%allocate(nrow,ncol,nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim - acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) - end do - call acoo%set_nzeros(nnzero) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - call acoo%allocate(nrow,ncol,2*nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim - acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) - end do - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = acoo%val(i) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then - ! we are generally working with non-symmetric matrices, so - ! we de-symmetrize what we are about to read - call acoo%allocate(nrow,ncol,2*nnzero) - do i=1,nnzero - read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim - acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) - end do - nzr = nnzero - do i=1,nnzero - if (acoo%ia(i) /= acoo%ja(i)) then - nzr = nzr + 1 - acoo%val(nzr) = conjg(acoo%val(i)) - acoo%ia(nzr) = acoo%ja(i) - acoo%ja(nzr) = acoo%ia(i) - end if - end do - call acoo%set_nzeros(nzr) - call acoo%fix(info) - - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') - - else - write(0,*) 'read_matrix: matrix type not yet supported' - info=904 - end if - if (infile/=5) close(infile) - return - - ! open failed -901 info=901 - write(0,*) 'read_matrix: could not open file ',filename,' for input' - return -902 info=902 - write(0,*) 'READ_MATRIX: Unexpected end of file ' - return -993 info=993 - write(0,*) 'READ_MATRIX: Memory allocation failure' - return - end subroutine zmm_mat_read - - - subroutine zmm_mat_write(a,mtitle,info,iunit,filename) - use psb_sparse_mod - implicit none - type(psb_z_sparse_mat), intent(in) :: a - integer, intent(out) :: info - character(len=*), intent(in) :: mtitle - integer, optional, intent(in) :: iunit - character(len=*), optional, intent(in) :: filename - integer :: iout - - - info = 0 - - if (present(filename)) then - if (filename=='-') then - iout=6 - else - if (present(iunit)) then - iout = iunit - else - iout=99 - endif - open(iout,file=filename, err=901, action='WRITE') - endif - else - if (present(iunit)) then - iout = iunit - else - iout=6 - endif - endif - - call a%print(iout,head=mtitle) - - if (iout /= 6) close(iout) - + interface mm_vet_write - return + subroutine mm_svet2_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_spk_ + implicit none + real(psb_spk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_svet2_write + subroutine mm_svet1_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_spk_ + implicit none + real(psb_spk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_svet1_write + subroutine mm_dvet2_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_dpk_ + implicit none + real(psb_dpk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_dvet2_write + subroutine mm_dvet1_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_dpk_ + implicit none + real(psb_dpk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_dvet1_write + subroutine mm_cvet2_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_spk_ + implicit none + complex(psb_spk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_cvet2_write + subroutine mm_cvet1_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_spk_ + implicit none + complex(psb_spk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_cvet1_write + subroutine mm_zvet2_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_dpk_ + implicit none + complex(psb_dpk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_zvet2_write + subroutine mm_zvet1_write(b, header, info, iunit, filename) + use psb_sparse_mod, only : psb_dpk_ + implicit none + complex(psb_dpk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine mm_zvet1_write + end interface -901 continue - info=901 - write(0,*) 'Error while opening ',filename - return - end subroutine zmm_mat_write + interface mm_mat_read + subroutine smm_mat_read(a, info, iunit, filename) + use psb_sparse_mod, only : psb_s_sparse_mat + implicit none + type(psb_s_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine smm_mat_read + subroutine dmm_mat_read(a, info, iunit, filename) + use psb_sparse_mod, only : psb_d_sparse_mat + implicit none + type(psb_d_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine dmm_mat_read + subroutine cmm_mat_read(a, info, iunit, filename) + use psb_sparse_mod, only : psb_c_sparse_mat + implicit none + type(psb_c_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine cmm_mat_read + subroutine zmm_mat_read(a, info, iunit, filename) + use psb_sparse_mod, only : psb_z_sparse_mat + implicit none + type(psb_z_sparse_mat), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine zmm_mat_read + end interface + interface mm_mat_write + subroutine smm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod, only : psb_s_sparse_mat + implicit none + type(psb_s_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine smm_mat_write + subroutine dmm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod, only : psb_d_sparse_mat + implicit none + type(psb_d_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine dmm_mat_write + subroutine cmm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod, only : psb_c_sparse_mat + implicit none + type(psb_c_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine cmm_mat_write + subroutine zmm_mat_write(a,mtitle,info,iunit,filename) + use psb_sparse_mod, only : psb_z_sparse_mat + implicit none + type(psb_z_sparse_mat), intent(in) :: a + integer, intent(out) :: info + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + end subroutine zmm_mat_write + end interface end module psb_mmio_mod