diff --git a/base/modules/serial/psb_base_mat_mod.f90 b/base/modules/serial/psb_base_mat_mod.f90 index 7bba8b06..1c197072 100644 --- a/base/modules/serial/psb_base_mat_mod.f90 +++ b/base/modules/serial/psb_base_mat_mod.f90 @@ -58,6 +58,15 @@ ! defined in the serial/f03/psb_base_mat_impl.f03 file ! ! +! +! We are also introducing the type psb_lbase_sparse_mat. +! The basic difference is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! +! module psb_base_mat_mod diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index befc89c6..5756df42 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -66,9 +66,16 @@ !| Update Assembled cscnv !| * unchanged reall !| Assembled Null free -! - - +! +! +! +! We are also introducing the type psb_lcspmat_type. +! The basic difference with psb_cspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! module psb_c_mat_mod use psb_c_base_mat_mod @@ -239,6 +246,148 @@ module psb_c_mat_mod end interface + type :: psb_lcspmat_type + + class(psb_lc_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_lc_get_nrows + procedure, pass(a) :: get_ncols => psb_lc_get_ncols + procedure, pass(a) :: get_nzeros => psb_lc_get_nzeros + procedure, pass(a) :: get_nz_row => psb_lc_get_nz_row + procedure, pass(a) :: get_size => psb_lc_get_size + procedure, pass(a) :: get_dupl => psb_lc_get_dupl + procedure, pass(a) :: is_null => psb_lc_is_null + procedure, pass(a) :: is_bld => psb_lc_is_bld + procedure, pass(a) :: is_upd => psb_lc_is_upd + procedure, pass(a) :: is_asb => psb_lc_is_asb + procedure, pass(a) :: is_sorted => psb_lc_is_sorted + procedure, pass(a) :: is_by_rows => psb_lc_is_by_rows + procedure, pass(a) :: is_by_cols => psb_lc_is_by_cols + procedure, pass(a) :: is_upper => psb_lc_is_upper + procedure, pass(a) :: is_lower => psb_lc_is_lower + procedure, pass(a) :: is_triangle => psb_lc_is_triangle + procedure, pass(a) :: is_unit => psb_lc_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_lc_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_lc_get_fmt + procedure, pass(a) :: sizeof => psb_lc_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_lc_set_nrows + procedure, pass(a) :: set_ncols => psb_lc_set_ncols + procedure, pass(a) :: set_dupl => psb_lc_set_dupl + procedure, pass(a) :: set_null => psb_lc_set_null + procedure, pass(a) :: set_bld => psb_lc_set_bld + procedure, pass(a) :: set_upd => psb_lc_set_upd + procedure, pass(a) :: set_asb => psb_lc_set_asb + procedure, pass(a) :: set_sorted => psb_lc_set_sorted + procedure, pass(a) :: set_upper => psb_lc_set_upper + procedure, pass(a) :: set_lower => psb_lc_set_lower + procedure, pass(a) :: set_triangle => psb_lc_set_triangle + procedure, pass(a) :: set_unit => psb_lc_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_lc_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_lc_csall + procedure, pass(a) :: free => psb_lc_free + procedure, pass(a) :: trim => psb_lc_trim + procedure, pass(a) :: csput_a => psb_lc_csput_a + procedure, pass(a) :: csput_v => psb_lc_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_lc_csgetptn + procedure, pass(a) :: csgetrow => psb_lc_csgetrow + procedure, pass(a) :: csgetblk => psb_lc_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_lc_icsgetptn + procedure, pass(a) :: icsgetrow => psb_lc_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_lc_tril + procedure, pass(a) :: triu => psb_lc_triu + procedure, pass(a) :: m_csclip => psb_lc_csclip + procedure, pass(a) :: b_csclip => psb_lc_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_lc_clean_zeros + procedure, pass(a) :: reall => psb_lc_reallocate_nz + procedure, pass(a) :: get_neigh => psb_lc_get_neigh + procedure, pass(a) :: reinit => psb_lc_reinit + procedure, pass(a) :: print_i => psb_lc_sparse_print + procedure, pass(a) :: print_n => psb_lc_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_lc_mold + procedure, pass(a) :: asb => psb_lc_asb + procedure, pass(a) :: transp_1mat => psb_lc_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lc_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_lc_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lc_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => lc_mat_sync + procedure, pass(a) :: is_host => lc_mat_is_host + procedure, pass(a) :: is_dev => lc_mat_is_dev + procedure, pass(a) :: is_sync => lc_mat_is_sync + procedure, pass(a) :: set_host => lc_mat_set_host + procedure, pass(a) :: set_dev => lc_mat_set_dev + procedure, pass(a) :: set_sync => lc_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_lc_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_lc_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_lc_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_lc_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_lc_cscnv + procedure, pass(a) :: cscnv_ip => psb_lc_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_lc_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_lcspmat_clone + + ! Computational routines + procedure, pass(a) :: get_diag => psb_lc_get_diag + procedure, pass(a) :: scals => psb_lc_scals + procedure, pass(a) :: scalv => psb_lc_scal + generic, public :: scal => scals, scalv + + end type psb_lcspmat_type + + private :: psb_lc_get_nrows, psb_lc_get_ncols, & + & psb_lc_get_nzeros, psb_lc_get_size, & + & psb_lc_get_dupl, psb_lc_is_null, psb_lc_is_bld, & + & psb_lc_is_upd, psb_lc_is_asb, psb_lc_is_sorted, & + & psb_lc_is_by_rows, psb_lc_is_by_cols, psb_lc_is_upper, & + & psb_lc_is_lower, psb_lc_is_triangle, psb_lc_get_nz_row, & + & lc_mat_sync, lc_mat_is_host, lc_mat_is_dev, & + & lc_mat_is_sync, lc_mat_set_host, lc_mat_set_dev,& + & lc_mat_set_sync + + + + class(psb_lc_base_sparse_mat), allocatable, target, & + & save, private :: psb_lc_base_mat_default + + interface psb_set_mat_default + module procedure psb_lc_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_lc_get_mat_default + end interface + + ! == =================================== ! ! @@ -271,7 +420,7 @@ module psb_c_mat_mod interface subroutine psb_c_set_dupl(n,a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_c_set_dupl @@ -279,35 +428,35 @@ module psb_c_mat_mod interface subroutine psb_c_set_null(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_null end interface interface subroutine psb_c_set_bld(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_bld end interface interface subroutine psb_c_set_upd(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_upd end interface interface subroutine psb_c_set_asb(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_asb end interface interface subroutine psb_c_set_sorted(a,val) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_sorted @@ -315,7 +464,7 @@ module psb_c_mat_mod interface subroutine psb_c_set_triangle(a,val) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_triangle @@ -323,7 +472,7 @@ module psb_c_mat_mod interface subroutine psb_c_set_unit(a,val) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_unit @@ -331,7 +480,7 @@ module psb_c_mat_mod interface subroutine psb_c_set_lower(a,val) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_lower @@ -339,7 +488,7 @@ module psb_c_mat_mod interface subroutine psb_c_set_upper(a,val) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_upper @@ -347,7 +496,7 @@ module psb_c_mat_mod interface subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type integer(psb_ipk_), intent(in) :: iout class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -358,7 +507,7 @@ module psb_c_mat_mod interface subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type character(len=*), intent(in) :: fname class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -369,7 +518,7 @@ module psb_c_mat_mod interface subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_), intent(out) :: n @@ -381,7 +530,7 @@ module psb_c_mat_mod interface subroutine psb_c_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info @@ -391,7 +540,7 @@ module psb_c_mat_mod interface subroutine psb_c_reallocate_nz(nz,a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_reallocate_nz @@ -399,21 +548,21 @@ module psb_c_mat_mod interface subroutine psb_c_free(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_free end interface interface subroutine psb_c_trim(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_trim end interface interface subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -427,7 +576,7 @@ module psb_c_mat_mod subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_c_vect_mod, only : psb_c_vect_type use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a type(psb_c_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -440,7 +589,7 @@ module psb_c_mat_mod interface subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -456,7 +605,7 @@ module psb_c_mat_mod interface subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -473,7 +622,7 @@ module psb_c_mat_mod interface subroutine psb_c_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -488,7 +637,7 @@ module psb_c_mat_mod interface subroutine psb_c_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -501,7 +650,7 @@ module psb_c_mat_mod interface subroutine psb_c_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -515,7 +664,7 @@ module psb_c_mat_mod interface subroutine psb_c_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -527,7 +676,7 @@ module psb_c_mat_mod interface subroutine psb_c_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_coo_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_coo_sparse_mat class(psb_cspmat_type), intent(in) :: a type(psb_c_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -538,7 +687,7 @@ module psb_c_mat_mod interface subroutine psb_c_mold(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_c_mold @@ -546,7 +695,7 @@ module psb_c_mat_mod interface subroutine psb_c_asb(a,mold) - import :: psb_ipk_, psb_cspmat_type, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_c_asb @@ -554,14 +703,14 @@ module psb_c_mat_mod interface subroutine psb_c_transp_1mat(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_transp_1mat end interface interface subroutine psb_c_transp_2mat(a,b) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b end subroutine psb_c_transp_2mat @@ -569,14 +718,14 @@ module psb_c_mat_mod interface subroutine psb_c_transc_1mat(a) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_transc_1mat end interface interface subroutine psb_c_transc_2mat(a,b) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b end subroutine psb_c_transc_2mat @@ -584,7 +733,7 @@ module psb_c_mat_mod interface subroutine psb_c_reinit(a,clear) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_reinit @@ -607,7 +756,7 @@ module psb_c_mat_mod ! interface subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -620,7 +769,7 @@ module psb_c_mat_mod interface subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: iinfo integer(psb_ipk_),optional, intent(in) :: dupl @@ -632,7 +781,7 @@ module psb_c_mat_mod interface subroutine psb_c_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +795,7 @@ module psb_c_mat_mod ! interface subroutine psb_c_clip_d(a,b,info) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -655,7 +804,7 @@ module psb_c_mat_mod interface subroutine psb_c_clip_d_ip(a,info) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_c_clip_d_ip @@ -667,7 +816,7 @@ module psb_c_mat_mod ! interface subroutine psb_c_mv_from(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_c_mv_from @@ -675,7 +824,7 @@ module psb_c_mat_mod interface subroutine psb_c_cp_from(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(out) :: a class(psb_c_base_sparse_mat), intent(in) :: b end subroutine psb_c_cp_from @@ -683,7 +832,7 @@ module psb_c_mat_mod interface subroutine psb_c_mv_to(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_c_mv_to @@ -691,7 +840,7 @@ module psb_c_mat_mod interface subroutine psb_c_cp_to(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_c_cp_to @@ -702,7 +851,7 @@ module psb_c_mat_mod ! interface psb_move_alloc subroutine psb_cspmat_type_move(a,b,info) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -711,7 +860,7 @@ module psb_c_mat_mod interface subroutine psb_cspmat_clone(a,b,info) - import :: psb_ipk_, psb_cspmat_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -736,7 +885,7 @@ module psb_c_mat_mod interface psb_csmm subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -744,7 +893,7 @@ module psb_c_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_csmm subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -753,7 +902,7 @@ module psb_c_mat_mod end subroutine psb_c_csmv subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_c_vect_mod, only : psb_c_vect_type - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta type(psb_c_vect_type), intent(inout) :: x @@ -765,7 +914,7 @@ module psb_c_mat_mod interface psb_cssm subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -774,7 +923,7 @@ module psb_c_mat_mod 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_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -784,7 +933,7 @@ module psb_c_mat_mod end subroutine psb_c_cssv subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_c_vect_mod, only : psb_c_vect_type - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta type(psb_c_vect_type), intent(inout) :: x @@ -797,7 +946,7 @@ module psb_c_mat_mod interface function psb_c_maxval(a) result(res) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_c_maxval @@ -805,7 +954,7 @@ module psb_c_mat_mod interface function psb_c_csnmi(a) result(res) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_c_csnmi @@ -813,7 +962,7 @@ module psb_c_mat_mod interface function psb_c_csnm1(a) result(res) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_c_csnm1 @@ -821,7 +970,7 @@ module psb_c_mat_mod interface function psb_c_rowsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -830,7 +979,7 @@ module psb_c_mat_mod interface function psb_c_arwsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -839,7 +988,7 @@ module psb_c_mat_mod interface function psb_c_colsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -848,7 +997,7 @@ module psb_c_mat_mod interface function psb_c_aclsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -857,7 +1006,7 @@ module psb_c_mat_mod interface function psb_c_get_diag(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -866,14 +1015,14 @@ module psb_c_mat_mod interface psb_scal subroutine psb_c_scal(d,a,info,side) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_c_scal subroutine psb_c_scals(d,a,info) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -881,51 +1030,12 @@ module psb_c_mat_mod end interface -contains - - - - subroutine psb_c_set_mat_default(a) - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - - if (allocated(psb_c_base_mat_default)) then - deallocate(psb_c_base_mat_default) - end if - allocate(psb_c_base_mat_default, mold=a) - - end subroutine psb_c_set_mat_default - - function psb_c_get_mat_default(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - class(psb_c_base_sparse_mat), pointer :: res - - res => psb_c_get_base_mat_default() - - end function psb_c_get_mat_default - - - function psb_c_get_base_mat_default() result(res) - implicit none - class(psb_c_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_c_base_mat_default)) then - allocate(psb_c_csr_sparse_mat :: psb_c_base_mat_default) - end if - - res => psb_c_base_mat_default - - end function psb_c_get_base_mat_default - - - - ! == =================================== ! ! ! - ! Getters + ! Setters + ! ! ! ! @@ -933,29 +1043,558 @@ contains ! ! == =================================== + + interface + subroutine psb_lc_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_lc_set_nrows + end interface - function psb_c_sizeof(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_epk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_c_sizeof + interface + subroutine psb_lc_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_lc_set_ncols + end interface + + interface + subroutine psb_lc_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_lc_set_dupl + end interface + + interface + subroutine psb_lc_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_null + end interface + + interface + subroutine psb_lc_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_bld + end interface + + interface + subroutine psb_lc_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_upd + end interface + + interface + subroutine psb_lc_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_asb + end interface + + interface + subroutine psb_lc_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_sorted + end interface + + interface + subroutine psb_lc_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_triangle + end interface + + interface + subroutine psb_lc_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_unit + end interface + + interface + subroutine psb_lc_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_lower + end interface + + interface + subroutine psb_lc_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_upper + end interface + + interface + subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_sparse_print + end interface + interface + subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + character(len=*), intent(in) :: fname + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_n_sparse_print + end interface + + interface + subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_lc_get_neigh + end interface + + interface + subroutine psb_lc_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_csall + end interface + + interface + subroutine psb_lc_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_reallocate_nz + end interface + + interface + subroutine psb_lc_free(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_free + end interface + + interface + subroutine psb_lc_trim(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_trim + end interface + + interface + subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csput_a + end interface - function psb_c_get_fmt(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - character(len=5) :: res + + interface + subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_vect_mod, only : psb_c_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + type(psb_c_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csput_v + end interface + + interface + subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csgetptn + end interface + + interface + subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csgetrow + end interface + + interface + subroutine psb_lc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csgetblk + end interface + + interface + subroutine psb_lc_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: u + end subroutine psb_lc_tril + end interface + + interface + subroutine psb_lc_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: l + end subroutine psb_lc_triu + end interface - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' + + interface + subroutine psb_lc_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csclip + end interface + + interface + subroutine psb_lc_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_coo_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + type(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_b_csclip + end interface + + interface + subroutine psb_lc_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_lc_mold + end interface + + interface + subroutine psb_lc_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_lc_asb + end interface + + interface + subroutine psb_lc_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_transp_1mat + end interface + + interface + subroutine psb_lc_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_lc_transp_2mat + end interface + + interface + subroutine psb_lc_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_transc_1mat + end interface + + interface + subroutine psb_lc_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_lc_transc_2mat + end interface + + interface + subroutine psb_lc_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lc_cscnv + end interface + + + interface + subroutine psb_lc_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lc_cscnv_ip + end interface + + + interface + subroutine psb_lc_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_lc_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_lc_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_mv_from + end interface + + interface + subroutine psb_lc_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(out) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + end subroutine psb_lc_cp_from + end interface + + interface + subroutine psb_lc_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_mv_to + end interface + + interface + subroutine psb_lc_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_cp_to + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_lcspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcspmat_type_move + end interface + + interface + subroutine psb_lcspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcspmat_clone + end interface + + + + interface + function psb_lc_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_get_diag + end interface + + interface psb_scal + subroutine psb_lc_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_scal + subroutine psb_lc_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_scals + end interface + + + + + +contains + + + + subroutine psb_c_set_mat_default(a) + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + + if (allocated(psb_c_base_mat_default)) then + deallocate(psb_c_base_mat_default) + end if + allocate(psb_c_base_mat_default, mold=a) + + end subroutine psb_c_set_mat_default + + function psb_c_get_mat_default(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), pointer :: res + + res => psb_c_get_base_mat_default() + + end function psb_c_get_mat_default + + + function psb_c_get_base_mat_default() result(res) + implicit none + class(psb_c_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_c_base_mat_default)) then + allocate(psb_c_csr_sparse_mat :: psb_c_base_mat_default) + end if + + res => psb_c_base_mat_default + + end function psb_c_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_c_sizeof(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_c_sizeof + + + function psb_c_get_fmt(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' end if end function psb_c_get_fmt @@ -1376,4 +2015,502 @@ contains end subroutine psb_c_lcsgetrow #endif + + ! + ! lc methods + ! + + + subroutine psb_lc_set_mat_default(a) + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + + if (allocated(psb_lc_base_mat_default)) then + deallocate(psb_lc_base_mat_default) + end if + allocate(psb_lc_base_mat_default, mold=a) + + end subroutine psb_lc_set_mat_default + + function psb_lc_get_mat_default(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), pointer :: res + + res => psb_lc_get_base_mat_default() + + end function psb_lc_get_mat_default + + + function psb_lc_get_base_mat_default() result(res) + implicit none + class(psb_lc_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_lc_base_mat_default)) then + allocate(psb_lc_csr_sparse_mat :: psb_lc_base_mat_default) + end if + + res => psb_lc_base_mat_default + + end function psb_lc_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_lc_sizeof(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_lc_sizeof + + + function psb_lc_get_fmt(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_lc_get_fmt + + + function psb_lc_get_dupl(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_lc_get_dupl + + function psb_lc_get_nrows(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_lc_get_nrows + + function psb_lc_get_ncols(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_lc_get_ncols + + function psb_lc_is_triangle(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_lc_is_triangle + + function psb_lc_is_unit(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_lc_is_unit + + function psb_lc_is_upper(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_lc_is_upper + + function psb_lc_is_lower(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_lc_is_lower + + function psb_lc_is_null(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_lc_is_null + + function psb_lc_is_bld(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_lc_is_bld + + function psb_lc_is_upd(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_lc_is_upd + + function psb_lc_is_asb(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_lc_is_asb + + function psb_lc_is_sorted(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_lc_is_sorted + + function psb_lc_is_by_rows(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_lc_is_by_rows + + function psb_lc_is_by_cols(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_lc_is_by_cols + + + ! + subroutine lc_mat_sync(a) + implicit none + class(psb_lcspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine lc_mat_sync + + ! + subroutine lc_mat_set_host(a) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine lc_mat_set_host + + + ! + subroutine lc_mat_set_dev(a) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine lc_mat_set_dev + + ! + subroutine lc_mat_set_sync(a) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine lc_mat_set_sync + + ! + function lc_mat_is_dev(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function lc_mat_is_dev + + ! + function lc_mat_is_host(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function lc_mat_is_host + + ! + function lc_mat_is_sync(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function lc_mat_is_sync + + + function psb_lc_is_repeatable_updates(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_lc_is_repeatable_updates + + subroutine psb_lc_set_repeatable_updates(a,val) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_lc_set_repeatable_updates + + + function psb_lc_get_nzeros(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_lc_get_nzeros + + function psb_lc_get_size(a) result(res) + + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_lc_get_size + + + function psb_lc_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_lc_get_nz_row + + subroutine psb_lc_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_lcspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_lc_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_lc_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lc_icsgetptn + + subroutine psb_lc_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lc_icsgetrow +#endif + end module psb_c_mat_mod diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index fd0a4845..76b5eae8 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -66,9 +66,16 @@ !| Update Assembled cscnv !| * unchanged reall !| Assembled Null free -! - - +! +! +! +! We are also introducing the type psb_ldspmat_type. +! The basic difference with psb_dspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! module psb_d_mat_mod use psb_d_base_mat_mod @@ -239,6 +246,148 @@ module psb_d_mat_mod end interface + type :: psb_ldspmat_type + + class(psb_ld_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_ld_get_nrows + procedure, pass(a) :: get_ncols => psb_ld_get_ncols + procedure, pass(a) :: get_nzeros => psb_ld_get_nzeros + procedure, pass(a) :: get_nz_row => psb_ld_get_nz_row + procedure, pass(a) :: get_size => psb_ld_get_size + procedure, pass(a) :: get_dupl => psb_ld_get_dupl + procedure, pass(a) :: is_null => psb_ld_is_null + procedure, pass(a) :: is_bld => psb_ld_is_bld + procedure, pass(a) :: is_upd => psb_ld_is_upd + procedure, pass(a) :: is_asb => psb_ld_is_asb + procedure, pass(a) :: is_sorted => psb_ld_is_sorted + procedure, pass(a) :: is_by_rows => psb_ld_is_by_rows + procedure, pass(a) :: is_by_cols => psb_ld_is_by_cols + procedure, pass(a) :: is_upper => psb_ld_is_upper + procedure, pass(a) :: is_lower => psb_ld_is_lower + procedure, pass(a) :: is_triangle => psb_ld_is_triangle + procedure, pass(a) :: is_unit => psb_ld_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_ld_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_ld_get_fmt + procedure, pass(a) :: sizeof => psb_ld_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_ld_set_nrows + procedure, pass(a) :: set_ncols => psb_ld_set_ncols + procedure, pass(a) :: set_dupl => psb_ld_set_dupl + procedure, pass(a) :: set_null => psb_ld_set_null + procedure, pass(a) :: set_bld => psb_ld_set_bld + procedure, pass(a) :: set_upd => psb_ld_set_upd + procedure, pass(a) :: set_asb => psb_ld_set_asb + procedure, pass(a) :: set_sorted => psb_ld_set_sorted + procedure, pass(a) :: set_upper => psb_ld_set_upper + procedure, pass(a) :: set_lower => psb_ld_set_lower + procedure, pass(a) :: set_triangle => psb_ld_set_triangle + procedure, pass(a) :: set_unit => psb_ld_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_ld_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_ld_csall + procedure, pass(a) :: free => psb_ld_free + procedure, pass(a) :: trim => psb_ld_trim + procedure, pass(a) :: csput_a => psb_ld_csput_a + procedure, pass(a) :: csput_v => psb_ld_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_ld_csgetptn + procedure, pass(a) :: csgetrow => psb_ld_csgetrow + procedure, pass(a) :: csgetblk => psb_ld_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_ld_icsgetptn + procedure, pass(a) :: icsgetrow => psb_ld_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_ld_tril + procedure, pass(a) :: triu => psb_ld_triu + procedure, pass(a) :: m_csclip => psb_ld_csclip + procedure, pass(a) :: b_csclip => psb_ld_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_ld_clean_zeros + procedure, pass(a) :: reall => psb_ld_reallocate_nz + procedure, pass(a) :: get_neigh => psb_ld_get_neigh + procedure, pass(a) :: reinit => psb_ld_reinit + procedure, pass(a) :: print_i => psb_ld_sparse_print + procedure, pass(a) :: print_n => psb_ld_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_ld_mold + procedure, pass(a) :: asb => psb_ld_asb + procedure, pass(a) :: transp_1mat => psb_ld_transp_1mat + procedure, pass(a) :: transp_2mat => psb_ld_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_ld_transc_1mat + procedure, pass(a) :: transc_2mat => psb_ld_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => ld_mat_sync + procedure, pass(a) :: is_host => ld_mat_is_host + procedure, pass(a) :: is_dev => ld_mat_is_dev + procedure, pass(a) :: is_sync => ld_mat_is_sync + procedure, pass(a) :: set_host => ld_mat_set_host + procedure, pass(a) :: set_dev => ld_mat_set_dev + procedure, pass(a) :: set_sync => ld_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_ld_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_ld_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_ld_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_ld_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_ld_cscnv + procedure, pass(a) :: cscnv_ip => psb_ld_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_ld_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_ldspmat_clone + + ! Computational routines + procedure, pass(a) :: get_diag => psb_ld_get_diag + procedure, pass(a) :: scals => psb_ld_scals + procedure, pass(a) :: scalv => psb_ld_scal + generic, public :: scal => scals, scalv + + end type psb_ldspmat_type + + private :: psb_ld_get_nrows, psb_ld_get_ncols, & + & psb_ld_get_nzeros, psb_ld_get_size, & + & psb_ld_get_dupl, psb_ld_is_null, psb_ld_is_bld, & + & psb_ld_is_upd, psb_ld_is_asb, psb_ld_is_sorted, & + & psb_ld_is_by_rows, psb_ld_is_by_cols, psb_ld_is_upper, & + & psb_ld_is_lower, psb_ld_is_triangle, psb_ld_get_nz_row, & + & ld_mat_sync, ld_mat_is_host, ld_mat_is_dev, & + & ld_mat_is_sync, ld_mat_set_host, ld_mat_set_dev,& + & ld_mat_set_sync + + + + class(psb_ld_base_sparse_mat), allocatable, target, & + & save, private :: psb_ld_base_mat_default + + interface psb_set_mat_default + module procedure psb_ld_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_ld_get_mat_default + end interface + + ! == =================================== ! ! @@ -271,7 +420,7 @@ module psb_d_mat_mod interface subroutine psb_d_set_dupl(n,a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_d_set_dupl @@ -279,35 +428,35 @@ module psb_d_mat_mod interface subroutine psb_d_set_null(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_null end interface interface subroutine psb_d_set_bld(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_bld end interface interface subroutine psb_d_set_upd(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_upd end interface interface subroutine psb_d_set_asb(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_asb end interface interface subroutine psb_d_set_sorted(a,val) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_sorted @@ -315,7 +464,7 @@ module psb_d_mat_mod interface subroutine psb_d_set_triangle(a,val) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_triangle @@ -323,7 +472,7 @@ module psb_d_mat_mod interface subroutine psb_d_set_unit(a,val) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_unit @@ -331,7 +480,7 @@ module psb_d_mat_mod interface subroutine psb_d_set_lower(a,val) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_lower @@ -339,7 +488,7 @@ module psb_d_mat_mod interface subroutine psb_d_set_upper(a,val) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_upper @@ -347,7 +496,7 @@ module psb_d_mat_mod interface subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type integer(psb_ipk_), intent(in) :: iout class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -358,7 +507,7 @@ module psb_d_mat_mod interface subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type character(len=*), intent(in) :: fname class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -369,7 +518,7 @@ module psb_d_mat_mod interface subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_), intent(out) :: n @@ -381,7 +530,7 @@ module psb_d_mat_mod interface subroutine psb_d_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info @@ -391,7 +540,7 @@ module psb_d_mat_mod interface subroutine psb_d_reallocate_nz(nz,a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_reallocate_nz @@ -399,21 +548,21 @@ module psb_d_mat_mod interface subroutine psb_d_free(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_free end interface interface subroutine psb_d_trim(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_trim end interface interface subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -427,7 +576,7 @@ module psb_d_mat_mod subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_d_vect_mod, only : psb_d_vect_type use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a type(psb_d_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -440,7 +589,7 @@ module psb_d_mat_mod interface subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -456,7 +605,7 @@ module psb_d_mat_mod interface subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -473,7 +622,7 @@ module psb_d_mat_mod interface subroutine psb_d_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -488,7 +637,7 @@ module psb_d_mat_mod interface subroutine psb_d_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -501,7 +650,7 @@ module psb_d_mat_mod interface subroutine psb_d_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -515,7 +664,7 @@ module psb_d_mat_mod interface subroutine psb_d_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -527,7 +676,7 @@ module psb_d_mat_mod interface subroutine psb_d_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_coo_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_coo_sparse_mat class(psb_dspmat_type), intent(in) :: a type(psb_d_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -538,7 +687,7 @@ module psb_d_mat_mod interface subroutine psb_d_mold(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_d_mold @@ -546,7 +695,7 @@ module psb_d_mat_mod interface subroutine psb_d_asb(a,mold) - import :: psb_ipk_, psb_dspmat_type, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_d_asb @@ -554,14 +703,14 @@ module psb_d_mat_mod interface subroutine psb_d_transp_1mat(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_transp_1mat end interface interface subroutine psb_d_transp_2mat(a,b) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b end subroutine psb_d_transp_2mat @@ -569,14 +718,14 @@ module psb_d_mat_mod interface subroutine psb_d_transc_1mat(a) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_transc_1mat end interface interface subroutine psb_d_transc_2mat(a,b) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b end subroutine psb_d_transc_2mat @@ -584,7 +733,7 @@ module psb_d_mat_mod interface subroutine psb_d_reinit(a,clear) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_reinit @@ -607,7 +756,7 @@ module psb_d_mat_mod ! interface subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -620,7 +769,7 @@ module psb_d_mat_mod interface subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: iinfo integer(psb_ipk_),optional, intent(in) :: dupl @@ -632,7 +781,7 @@ module psb_d_mat_mod interface subroutine psb_d_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +795,7 @@ module psb_d_mat_mod ! interface subroutine psb_d_clip_d(a,b,info) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -655,7 +804,7 @@ module psb_d_mat_mod interface subroutine psb_d_clip_d_ip(a,info) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_d_clip_d_ip @@ -667,7 +816,7 @@ module psb_d_mat_mod ! interface subroutine psb_d_mv_from(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_d_mv_from @@ -675,7 +824,7 @@ module psb_d_mat_mod interface subroutine psb_d_cp_from(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(out) :: a class(psb_d_base_sparse_mat), intent(in) :: b end subroutine psb_d_cp_from @@ -683,7 +832,7 @@ module psb_d_mat_mod interface subroutine psb_d_mv_to(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_d_mv_to @@ -691,7 +840,7 @@ module psb_d_mat_mod interface subroutine psb_d_cp_to(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_d_cp_to @@ -702,7 +851,7 @@ module psb_d_mat_mod ! interface psb_move_alloc subroutine psb_dspmat_type_move(a,b,info) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -711,7 +860,7 @@ module psb_d_mat_mod interface subroutine psb_dspmat_clone(a,b,info) - import :: psb_ipk_, psb_dspmat_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -736,7 +885,7 @@ module psb_d_mat_mod interface psb_csmm subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -744,7 +893,7 @@ module psb_d_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_csmm subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -753,7 +902,7 @@ module psb_d_mat_mod end subroutine psb_d_csmv subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_d_vect_mod, only : psb_d_vect_type - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta type(psb_d_vect_type), intent(inout) :: x @@ -765,7 +914,7 @@ module psb_d_mat_mod interface psb_cssm subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -774,7 +923,7 @@ module psb_d_mat_mod 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_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -784,7 +933,7 @@ module psb_d_mat_mod end subroutine psb_d_cssv subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_d_vect_mod, only : psb_d_vect_type - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta type(psb_d_vect_type), intent(inout) :: x @@ -797,7 +946,7 @@ module psb_d_mat_mod interface function psb_d_maxval(a) result(res) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_d_maxval @@ -805,7 +954,7 @@ module psb_d_mat_mod interface function psb_d_csnmi(a) result(res) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csnmi @@ -813,7 +962,7 @@ module psb_d_mat_mod interface function psb_d_csnm1(a) result(res) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csnm1 @@ -821,7 +970,7 @@ module psb_d_mat_mod interface function psb_d_rowsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -830,7 +979,7 @@ module psb_d_mat_mod interface function psb_d_arwsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -839,7 +988,7 @@ module psb_d_mat_mod interface function psb_d_colsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -848,7 +997,7 @@ module psb_d_mat_mod interface function psb_d_aclsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -857,7 +1006,7 @@ module psb_d_mat_mod interface function psb_d_get_diag(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -866,14 +1015,14 @@ module psb_d_mat_mod interface psb_scal subroutine psb_d_scal(d,a,info,side) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_d_scal subroutine psb_d_scals(d,a,info) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -881,51 +1030,12 @@ module psb_d_mat_mod end interface -contains - - - - subroutine psb_d_set_mat_default(a) - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - - if (allocated(psb_d_base_mat_default)) then - deallocate(psb_d_base_mat_default) - end if - allocate(psb_d_base_mat_default, mold=a) - - end subroutine psb_d_set_mat_default - - function psb_d_get_mat_default(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - class(psb_d_base_sparse_mat), pointer :: res - - res => psb_d_get_base_mat_default() - - end function psb_d_get_mat_default - - - function psb_d_get_base_mat_default() result(res) - implicit none - class(psb_d_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_d_base_mat_default)) then - allocate(psb_d_csr_sparse_mat :: psb_d_base_mat_default) - end if - - res => psb_d_base_mat_default - - end function psb_d_get_base_mat_default - - - - ! == =================================== ! ! ! - ! Getters + ! Setters + ! ! ! ! @@ -933,29 +1043,558 @@ contains ! ! == =================================== + + interface + subroutine psb_ld_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_ld_set_nrows + end interface - function psb_d_sizeof(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_epk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_d_sizeof + interface + subroutine psb_ld_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_ld_set_ncols + end interface + + interface + subroutine psb_ld_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_ld_set_dupl + end interface + + interface + subroutine psb_ld_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_null + end interface + + interface + subroutine psb_ld_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_bld + end interface + + interface + subroutine psb_ld_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_upd + end interface + + interface + subroutine psb_ld_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_asb + end interface + + interface + subroutine psb_ld_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_sorted + end interface + + interface + subroutine psb_ld_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_triangle + end interface + + interface + subroutine psb_ld_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_unit + end interface + + interface + subroutine psb_ld_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_lower + end interface + + interface + subroutine psb_ld_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_upper + end interface + + interface + subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_sparse_print + end interface + interface + subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + character(len=*), intent(in) :: fname + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_n_sparse_print + end interface + + interface + subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_ld_get_neigh + end interface + + interface + subroutine psb_ld_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_csall + end interface + + interface + subroutine psb_ld_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_reallocate_nz + end interface + + interface + subroutine psb_ld_free(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_free + end interface + + interface + subroutine psb_ld_trim(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_trim + end interface + + interface + subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csput_a + end interface - function psb_d_get_fmt(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - character(len=5) :: res + + interface + subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_vect_mod, only : psb_d_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + type(psb_d_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csput_v + end interface + + interface + subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csgetptn + end interface + + interface + subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csgetrow + end interface + + interface + subroutine psb_ld_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csgetblk + end interface + + interface + subroutine psb_ld_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: u + end subroutine psb_ld_tril + end interface + + interface + subroutine psb_ld_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: l + end subroutine psb_ld_triu + end interface - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' + + interface + subroutine psb_ld_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csclip + end interface + + interface + subroutine psb_ld_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_coo_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + type(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_b_csclip + end interface + + interface + subroutine psb_ld_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_ld_mold + end interface + + interface + subroutine psb_ld_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_ld_asb + end interface + + interface + subroutine psb_ld_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_transp_1mat + end interface + + interface + subroutine psb_ld_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_ld_transp_2mat + end interface + + interface + subroutine psb_ld_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_transc_1mat + end interface + + interface + subroutine psb_ld_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_ld_transc_2mat + end interface + + interface + subroutine psb_ld_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ld_cscnv + end interface + + + interface + subroutine psb_ld_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ld_cscnv_ip + end interface + + + interface + subroutine psb_ld_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_ld_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_ld_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_mv_from + end interface + + interface + subroutine psb_ld_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(out) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + end subroutine psb_ld_cp_from + end interface + + interface + subroutine psb_ld_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_mv_to + end interface + + interface + subroutine psb_ld_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_cp_to + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_ldspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldspmat_type_move + end interface + + interface + subroutine psb_ldspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldspmat_clone + end interface + + + + interface + function psb_ld_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_get_diag + end interface + + interface psb_scal + subroutine psb_ld_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_scal + subroutine psb_ld_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_scals + end interface + + + + + +contains + + + + subroutine psb_d_set_mat_default(a) + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + + if (allocated(psb_d_base_mat_default)) then + deallocate(psb_d_base_mat_default) + end if + allocate(psb_d_base_mat_default, mold=a) + + end subroutine psb_d_set_mat_default + + function psb_d_get_mat_default(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), pointer :: res + + res => psb_d_get_base_mat_default() + + end function psb_d_get_mat_default + + + function psb_d_get_base_mat_default() result(res) + implicit none + class(psb_d_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_d_base_mat_default)) then + allocate(psb_d_csr_sparse_mat :: psb_d_base_mat_default) + end if + + res => psb_d_base_mat_default + + end function psb_d_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_d_sizeof(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_d_sizeof + + + function psb_d_get_fmt(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' end if end function psb_d_get_fmt @@ -1376,4 +2015,502 @@ contains end subroutine psb_d_lcsgetrow #endif + + ! + ! ld methods + ! + + + subroutine psb_ld_set_mat_default(a) + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + + if (allocated(psb_ld_base_mat_default)) then + deallocate(psb_ld_base_mat_default) + end if + allocate(psb_ld_base_mat_default, mold=a) + + end subroutine psb_ld_set_mat_default + + function psb_ld_get_mat_default(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), pointer :: res + + res => psb_ld_get_base_mat_default() + + end function psb_ld_get_mat_default + + + function psb_ld_get_base_mat_default() result(res) + implicit none + class(psb_ld_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_ld_base_mat_default)) then + allocate(psb_ld_csr_sparse_mat :: psb_ld_base_mat_default) + end if + + res => psb_ld_base_mat_default + + end function psb_ld_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_ld_sizeof(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_ld_sizeof + + + function psb_ld_get_fmt(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_ld_get_fmt + + + function psb_ld_get_dupl(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_ld_get_dupl + + function psb_ld_get_nrows(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_ld_get_nrows + + function psb_ld_get_ncols(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_ld_get_ncols + + function psb_ld_is_triangle(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_ld_is_triangle + + function psb_ld_is_unit(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_ld_is_unit + + function psb_ld_is_upper(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_ld_is_upper + + function psb_ld_is_lower(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_ld_is_lower + + function psb_ld_is_null(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_ld_is_null + + function psb_ld_is_bld(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_ld_is_bld + + function psb_ld_is_upd(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_ld_is_upd + + function psb_ld_is_asb(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_ld_is_asb + + function psb_ld_is_sorted(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_ld_is_sorted + + function psb_ld_is_by_rows(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_ld_is_by_rows + + function psb_ld_is_by_cols(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_ld_is_by_cols + + + ! + subroutine ld_mat_sync(a) + implicit none + class(psb_ldspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine ld_mat_sync + + ! + subroutine ld_mat_set_host(a) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine ld_mat_set_host + + + ! + subroutine ld_mat_set_dev(a) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine ld_mat_set_dev + + ! + subroutine ld_mat_set_sync(a) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine ld_mat_set_sync + + ! + function ld_mat_is_dev(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function ld_mat_is_dev + + ! + function ld_mat_is_host(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function ld_mat_is_host + + ! + function ld_mat_is_sync(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function ld_mat_is_sync + + + function psb_ld_is_repeatable_updates(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_ld_is_repeatable_updates + + subroutine psb_ld_set_repeatable_updates(a,val) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_ld_set_repeatable_updates + + + function psb_ld_get_nzeros(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_ld_get_nzeros + + function psb_ld_get_size(a) result(res) + + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_ld_get_size + + + function psb_ld_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_ld_get_nz_row + + subroutine psb_ld_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_ldspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_ld_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_ld_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ld_icsgetptn + + subroutine psb_ld_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ld_icsgetrow +#endif + end module psb_d_mat_mod diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 24eb523a..c8d03696 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -66,9 +66,16 @@ !| Update Assembled cscnv !| * unchanged reall !| Assembled Null free -! - - +! +! +! +! We are also introducing the type psb_lsspmat_type. +! The basic difference with psb_sspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! module psb_s_mat_mod use psb_s_base_mat_mod @@ -239,6 +246,148 @@ module psb_s_mat_mod end interface + type :: psb_lsspmat_type + + class(psb_ls_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_ls_get_nrows + procedure, pass(a) :: get_ncols => psb_ls_get_ncols + procedure, pass(a) :: get_nzeros => psb_ls_get_nzeros + procedure, pass(a) :: get_nz_row => psb_ls_get_nz_row + procedure, pass(a) :: get_size => psb_ls_get_size + procedure, pass(a) :: get_dupl => psb_ls_get_dupl + procedure, pass(a) :: is_null => psb_ls_is_null + procedure, pass(a) :: is_bld => psb_ls_is_bld + procedure, pass(a) :: is_upd => psb_ls_is_upd + procedure, pass(a) :: is_asb => psb_ls_is_asb + procedure, pass(a) :: is_sorted => psb_ls_is_sorted + procedure, pass(a) :: is_by_rows => psb_ls_is_by_rows + procedure, pass(a) :: is_by_cols => psb_ls_is_by_cols + procedure, pass(a) :: is_upper => psb_ls_is_upper + procedure, pass(a) :: is_lower => psb_ls_is_lower + procedure, pass(a) :: is_triangle => psb_ls_is_triangle + procedure, pass(a) :: is_unit => psb_ls_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_ls_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_ls_get_fmt + procedure, pass(a) :: sizeof => psb_ls_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_ls_set_nrows + procedure, pass(a) :: set_ncols => psb_ls_set_ncols + procedure, pass(a) :: set_dupl => psb_ls_set_dupl + procedure, pass(a) :: set_null => psb_ls_set_null + procedure, pass(a) :: set_bld => psb_ls_set_bld + procedure, pass(a) :: set_upd => psb_ls_set_upd + procedure, pass(a) :: set_asb => psb_ls_set_asb + procedure, pass(a) :: set_sorted => psb_ls_set_sorted + procedure, pass(a) :: set_upper => psb_ls_set_upper + procedure, pass(a) :: set_lower => psb_ls_set_lower + procedure, pass(a) :: set_triangle => psb_ls_set_triangle + procedure, pass(a) :: set_unit => psb_ls_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_ls_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_ls_csall + procedure, pass(a) :: free => psb_ls_free + procedure, pass(a) :: trim => psb_ls_trim + procedure, pass(a) :: csput_a => psb_ls_csput_a + procedure, pass(a) :: csput_v => psb_ls_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_ls_csgetptn + procedure, pass(a) :: csgetrow => psb_ls_csgetrow + procedure, pass(a) :: csgetblk => psb_ls_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_ls_icsgetptn + procedure, pass(a) :: icsgetrow => psb_ls_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_ls_tril + procedure, pass(a) :: triu => psb_ls_triu + procedure, pass(a) :: m_csclip => psb_ls_csclip + procedure, pass(a) :: b_csclip => psb_ls_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_ls_clean_zeros + procedure, pass(a) :: reall => psb_ls_reallocate_nz + procedure, pass(a) :: get_neigh => psb_ls_get_neigh + procedure, pass(a) :: reinit => psb_ls_reinit + procedure, pass(a) :: print_i => psb_ls_sparse_print + procedure, pass(a) :: print_n => psb_ls_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_ls_mold + procedure, pass(a) :: asb => psb_ls_asb + procedure, pass(a) :: transp_1mat => psb_ls_transp_1mat + procedure, pass(a) :: transp_2mat => psb_ls_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_ls_transc_1mat + procedure, pass(a) :: transc_2mat => psb_ls_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => ls_mat_sync + procedure, pass(a) :: is_host => ls_mat_is_host + procedure, pass(a) :: is_dev => ls_mat_is_dev + procedure, pass(a) :: is_sync => ls_mat_is_sync + procedure, pass(a) :: set_host => ls_mat_set_host + procedure, pass(a) :: set_dev => ls_mat_set_dev + procedure, pass(a) :: set_sync => ls_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_ls_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_ls_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_ls_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_ls_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_ls_cscnv + procedure, pass(a) :: cscnv_ip => psb_ls_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_ls_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_lsspmat_clone + + ! Computational routines + procedure, pass(a) :: get_diag => psb_ls_get_diag + procedure, pass(a) :: scals => psb_ls_scals + procedure, pass(a) :: scalv => psb_ls_scal + generic, public :: scal => scals, scalv + + end type psb_lsspmat_type + + private :: psb_ls_get_nrows, psb_ls_get_ncols, & + & psb_ls_get_nzeros, psb_ls_get_size, & + & psb_ls_get_dupl, psb_ls_is_null, psb_ls_is_bld, & + & psb_ls_is_upd, psb_ls_is_asb, psb_ls_is_sorted, & + & psb_ls_is_by_rows, psb_ls_is_by_cols, psb_ls_is_upper, & + & psb_ls_is_lower, psb_ls_is_triangle, psb_ls_get_nz_row, & + & ls_mat_sync, ls_mat_is_host, ls_mat_is_dev, & + & ls_mat_is_sync, ls_mat_set_host, ls_mat_set_dev,& + & ls_mat_set_sync + + + + class(psb_ls_base_sparse_mat), allocatable, target, & + & save, private :: psb_ls_base_mat_default + + interface psb_set_mat_default + module procedure psb_ls_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_ls_get_mat_default + end interface + + ! == =================================== ! ! @@ -271,7 +420,7 @@ module psb_s_mat_mod interface subroutine psb_s_set_dupl(n,a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_s_set_dupl @@ -279,35 +428,35 @@ module psb_s_mat_mod interface subroutine psb_s_set_null(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_null end interface interface subroutine psb_s_set_bld(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_bld end interface interface subroutine psb_s_set_upd(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_upd end interface interface subroutine psb_s_set_asb(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_asb end interface interface subroutine psb_s_set_sorted(a,val) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_sorted @@ -315,7 +464,7 @@ module psb_s_mat_mod interface subroutine psb_s_set_triangle(a,val) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_triangle @@ -323,7 +472,7 @@ module psb_s_mat_mod interface subroutine psb_s_set_unit(a,val) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_unit @@ -331,7 +480,7 @@ module psb_s_mat_mod interface subroutine psb_s_set_lower(a,val) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_lower @@ -339,7 +488,7 @@ module psb_s_mat_mod interface subroutine psb_s_set_upper(a,val) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_upper @@ -347,7 +496,7 @@ module psb_s_mat_mod interface subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type integer(psb_ipk_), intent(in) :: iout class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -358,7 +507,7 @@ module psb_s_mat_mod interface subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type character(len=*), intent(in) :: fname class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -369,7 +518,7 @@ module psb_s_mat_mod interface subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_), intent(out) :: n @@ -381,7 +530,7 @@ module psb_s_mat_mod interface subroutine psb_s_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info @@ -391,7 +540,7 @@ module psb_s_mat_mod interface subroutine psb_s_reallocate_nz(nz,a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_reallocate_nz @@ -399,21 +548,21 @@ module psb_s_mat_mod interface subroutine psb_s_free(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_free end interface interface subroutine psb_s_trim(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_trim end interface interface subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -427,7 +576,7 @@ module psb_s_mat_mod subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_s_vect_mod, only : psb_s_vect_type use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a type(psb_s_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -440,7 +589,7 @@ module psb_s_mat_mod interface subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -456,7 +605,7 @@ module psb_s_mat_mod interface subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -473,7 +622,7 @@ module psb_s_mat_mod interface subroutine psb_s_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -488,7 +637,7 @@ module psb_s_mat_mod interface subroutine psb_s_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -501,7 +650,7 @@ module psb_s_mat_mod interface subroutine psb_s_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -515,7 +664,7 @@ module psb_s_mat_mod interface subroutine psb_s_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -527,7 +676,7 @@ module psb_s_mat_mod interface subroutine psb_s_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_coo_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_coo_sparse_mat class(psb_sspmat_type), intent(in) :: a type(psb_s_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -538,7 +687,7 @@ module psb_s_mat_mod interface subroutine psb_s_mold(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_s_mold @@ -546,7 +695,7 @@ module psb_s_mat_mod interface subroutine psb_s_asb(a,mold) - import :: psb_ipk_, psb_sspmat_type, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_s_asb @@ -554,14 +703,14 @@ module psb_s_mat_mod interface subroutine psb_s_transp_1mat(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_transp_1mat end interface interface subroutine psb_s_transp_2mat(a,b) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b end subroutine psb_s_transp_2mat @@ -569,14 +718,14 @@ module psb_s_mat_mod interface subroutine psb_s_transc_1mat(a) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_transc_1mat end interface interface subroutine psb_s_transc_2mat(a,b) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b end subroutine psb_s_transc_2mat @@ -584,7 +733,7 @@ module psb_s_mat_mod interface subroutine psb_s_reinit(a,clear) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_reinit @@ -607,7 +756,7 @@ module psb_s_mat_mod ! interface subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -620,7 +769,7 @@ module psb_s_mat_mod interface subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: iinfo integer(psb_ipk_),optional, intent(in) :: dupl @@ -632,7 +781,7 @@ module psb_s_mat_mod interface subroutine psb_s_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +795,7 @@ module psb_s_mat_mod ! interface subroutine psb_s_clip_d(a,b,info) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -655,7 +804,7 @@ module psb_s_mat_mod interface subroutine psb_s_clip_d_ip(a,info) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_s_clip_d_ip @@ -667,7 +816,7 @@ module psb_s_mat_mod ! interface subroutine psb_s_mv_from(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_s_mv_from @@ -675,7 +824,7 @@ module psb_s_mat_mod interface subroutine psb_s_cp_from(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(out) :: a class(psb_s_base_sparse_mat), intent(in) :: b end subroutine psb_s_cp_from @@ -683,7 +832,7 @@ module psb_s_mat_mod interface subroutine psb_s_mv_to(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_s_mv_to @@ -691,7 +840,7 @@ module psb_s_mat_mod interface subroutine psb_s_cp_to(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_s_cp_to @@ -702,7 +851,7 @@ module psb_s_mat_mod ! interface psb_move_alloc subroutine psb_sspmat_type_move(a,b,info) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -711,7 +860,7 @@ module psb_s_mat_mod interface subroutine psb_sspmat_clone(a,b,info) - import :: psb_ipk_, psb_sspmat_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -736,7 +885,7 @@ module psb_s_mat_mod interface psb_csmm subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -744,7 +893,7 @@ module psb_s_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_csmm subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -753,7 +902,7 @@ module psb_s_mat_mod end subroutine psb_s_csmv subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_s_vect_mod, only : psb_s_vect_type - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta type(psb_s_vect_type), intent(inout) :: x @@ -765,7 +914,7 @@ module psb_s_mat_mod interface psb_cssm subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -774,7 +923,7 @@ module psb_s_mat_mod 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_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -784,7 +933,7 @@ module psb_s_mat_mod end subroutine psb_s_cssv subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_s_vect_mod, only : psb_s_vect_type - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta type(psb_s_vect_type), intent(inout) :: x @@ -797,7 +946,7 @@ module psb_s_mat_mod interface function psb_s_maxval(a) result(res) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_s_maxval @@ -805,7 +954,7 @@ module psb_s_mat_mod interface function psb_s_csnmi(a) result(res) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_s_csnmi @@ -813,7 +962,7 @@ module psb_s_mat_mod interface function psb_s_csnm1(a) result(res) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_s_csnm1 @@ -821,7 +970,7 @@ module psb_s_mat_mod interface function psb_s_rowsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -830,7 +979,7 @@ module psb_s_mat_mod interface function psb_s_arwsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -839,7 +988,7 @@ module psb_s_mat_mod interface function psb_s_colsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -848,7 +997,7 @@ module psb_s_mat_mod interface function psb_s_aclsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -857,7 +1006,7 @@ module psb_s_mat_mod interface function psb_s_get_diag(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -866,14 +1015,14 @@ module psb_s_mat_mod interface psb_scal subroutine psb_s_scal(d,a,info,side) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_s_scal subroutine psb_s_scals(d,a,info) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -881,51 +1030,12 @@ module psb_s_mat_mod end interface -contains - - - - subroutine psb_s_set_mat_default(a) - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - - if (allocated(psb_s_base_mat_default)) then - deallocate(psb_s_base_mat_default) - end if - allocate(psb_s_base_mat_default, mold=a) - - end subroutine psb_s_set_mat_default - - function psb_s_get_mat_default(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - class(psb_s_base_sparse_mat), pointer :: res - - res => psb_s_get_base_mat_default() - - end function psb_s_get_mat_default - - - function psb_s_get_base_mat_default() result(res) - implicit none - class(psb_s_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_s_base_mat_default)) then - allocate(psb_s_csr_sparse_mat :: psb_s_base_mat_default) - end if - - res => psb_s_base_mat_default - - end function psb_s_get_base_mat_default - - - - ! == =================================== ! ! ! - ! Getters + ! Setters + ! ! ! ! @@ -933,29 +1043,558 @@ contains ! ! == =================================== + + interface + subroutine psb_ls_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_ls_set_nrows + end interface - function psb_s_sizeof(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_epk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_s_sizeof + interface + subroutine psb_ls_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_ls_set_ncols + end interface + + interface + subroutine psb_ls_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_ls_set_dupl + end interface + + interface + subroutine psb_ls_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_null + end interface + + interface + subroutine psb_ls_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_bld + end interface + + interface + subroutine psb_ls_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_upd + end interface + + interface + subroutine psb_ls_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_asb + end interface + + interface + subroutine psb_ls_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_sorted + end interface + + interface + subroutine psb_ls_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_triangle + end interface + + interface + subroutine psb_ls_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_unit + end interface + + interface + subroutine psb_ls_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_lower + end interface + + interface + subroutine psb_ls_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_upper + end interface + + interface + subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_sparse_print + end interface + interface + subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + character(len=*), intent(in) :: fname + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_n_sparse_print + end interface + + interface + subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_ls_get_neigh + end interface + + interface + subroutine psb_ls_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_csall + end interface + + interface + subroutine psb_ls_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_reallocate_nz + end interface + + interface + subroutine psb_ls_free(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_free + end interface + + interface + subroutine psb_ls_trim(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_trim + end interface + + interface + subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csput_a + end interface - function psb_s_get_fmt(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - character(len=5) :: res + + interface + subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_vect_mod, only : psb_s_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + type(psb_s_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csput_v + end interface + + interface + subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csgetptn + end interface + + interface + subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csgetrow + end interface + + interface + subroutine psb_ls_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csgetblk + end interface + + interface + subroutine psb_ls_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: u + end subroutine psb_ls_tril + end interface + + interface + subroutine psb_ls_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: l + end subroutine psb_ls_triu + end interface - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' + + interface + subroutine psb_ls_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csclip + end interface + + interface + subroutine psb_ls_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_coo_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + type(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_b_csclip + end interface + + interface + subroutine psb_ls_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_ls_mold + end interface + + interface + subroutine psb_ls_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_ls_asb + end interface + + interface + subroutine psb_ls_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_transp_1mat + end interface + + interface + subroutine psb_ls_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_ls_transp_2mat + end interface + + interface + subroutine psb_ls_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_transc_1mat + end interface + + interface + subroutine psb_ls_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_ls_transc_2mat + end interface + + interface + subroutine psb_ls_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ls_cscnv + end interface + + + interface + subroutine psb_ls_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ls_cscnv_ip + end interface + + + interface + subroutine psb_ls_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_ls_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_ls_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_mv_from + end interface + + interface + subroutine psb_ls_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(out) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + end subroutine psb_ls_cp_from + end interface + + interface + subroutine psb_ls_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_mv_to + end interface + + interface + subroutine psb_ls_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_cp_to + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_lsspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsspmat_type_move + end interface + + interface + subroutine psb_lsspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsspmat_clone + end interface + + + + interface + function psb_ls_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_get_diag + end interface + + interface psb_scal + subroutine psb_ls_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_scal + subroutine psb_ls_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_scals + end interface + + + + + +contains + + + + subroutine psb_s_set_mat_default(a) + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + + if (allocated(psb_s_base_mat_default)) then + deallocate(psb_s_base_mat_default) + end if + allocate(psb_s_base_mat_default, mold=a) + + end subroutine psb_s_set_mat_default + + function psb_s_get_mat_default(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), pointer :: res + + res => psb_s_get_base_mat_default() + + end function psb_s_get_mat_default + + + function psb_s_get_base_mat_default() result(res) + implicit none + class(psb_s_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_s_base_mat_default)) then + allocate(psb_s_csr_sparse_mat :: psb_s_base_mat_default) + end if + + res => psb_s_base_mat_default + + end function psb_s_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_s_sizeof(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_s_sizeof + + + function psb_s_get_fmt(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' end if end function psb_s_get_fmt @@ -1376,4 +2015,502 @@ contains end subroutine psb_s_lcsgetrow #endif + + ! + ! ls methods + ! + + + subroutine psb_ls_set_mat_default(a) + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + + if (allocated(psb_ls_base_mat_default)) then + deallocate(psb_ls_base_mat_default) + end if + allocate(psb_ls_base_mat_default, mold=a) + + end subroutine psb_ls_set_mat_default + + function psb_ls_get_mat_default(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), pointer :: res + + res => psb_ls_get_base_mat_default() + + end function psb_ls_get_mat_default + + + function psb_ls_get_base_mat_default() result(res) + implicit none + class(psb_ls_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_ls_base_mat_default)) then + allocate(psb_ls_csr_sparse_mat :: psb_ls_base_mat_default) + end if + + res => psb_ls_base_mat_default + + end function psb_ls_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_ls_sizeof(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_ls_sizeof + + + function psb_ls_get_fmt(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_ls_get_fmt + + + function psb_ls_get_dupl(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_ls_get_dupl + + function psb_ls_get_nrows(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_ls_get_nrows + + function psb_ls_get_ncols(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_ls_get_ncols + + function psb_ls_is_triangle(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_ls_is_triangle + + function psb_ls_is_unit(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_ls_is_unit + + function psb_ls_is_upper(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_ls_is_upper + + function psb_ls_is_lower(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_ls_is_lower + + function psb_ls_is_null(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_ls_is_null + + function psb_ls_is_bld(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_ls_is_bld + + function psb_ls_is_upd(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_ls_is_upd + + function psb_ls_is_asb(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_ls_is_asb + + function psb_ls_is_sorted(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_ls_is_sorted + + function psb_ls_is_by_rows(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_ls_is_by_rows + + function psb_ls_is_by_cols(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_ls_is_by_cols + + + ! + subroutine ls_mat_sync(a) + implicit none + class(psb_lsspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine ls_mat_sync + + ! + subroutine ls_mat_set_host(a) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine ls_mat_set_host + + + ! + subroutine ls_mat_set_dev(a) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine ls_mat_set_dev + + ! + subroutine ls_mat_set_sync(a) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine ls_mat_set_sync + + ! + function ls_mat_is_dev(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function ls_mat_is_dev + + ! + function ls_mat_is_host(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function ls_mat_is_host + + ! + function ls_mat_is_sync(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function ls_mat_is_sync + + + function psb_ls_is_repeatable_updates(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_ls_is_repeatable_updates + + subroutine psb_ls_set_repeatable_updates(a,val) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_ls_set_repeatable_updates + + + function psb_ls_get_nzeros(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_ls_get_nzeros + + function psb_ls_get_size(a) result(res) + + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_ls_get_size + + + function psb_ls_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_ls_get_nz_row + + subroutine psb_ls_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_lsspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_ls_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_ls_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ls_icsgetptn + + subroutine psb_ls_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ls_icsgetrow +#endif + end module psb_s_mat_mod diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index 784ef388..9e6b253c 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -66,9 +66,16 @@ !| Update Assembled cscnv !| * unchanged reall !| Assembled Null free -! - - +! +! +! +! We are also introducing the type psb_lzspmat_type. +! The basic difference with psb_zspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! module psb_z_mat_mod use psb_z_base_mat_mod @@ -239,6 +246,148 @@ module psb_z_mat_mod end interface + type :: psb_lzspmat_type + + class(psb_lz_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_lz_get_nrows + procedure, pass(a) :: get_ncols => psb_lz_get_ncols + procedure, pass(a) :: get_nzeros => psb_lz_get_nzeros + procedure, pass(a) :: get_nz_row => psb_lz_get_nz_row + procedure, pass(a) :: get_size => psb_lz_get_size + procedure, pass(a) :: get_dupl => psb_lz_get_dupl + procedure, pass(a) :: is_null => psb_lz_is_null + procedure, pass(a) :: is_bld => psb_lz_is_bld + procedure, pass(a) :: is_upd => psb_lz_is_upd + procedure, pass(a) :: is_asb => psb_lz_is_asb + procedure, pass(a) :: is_sorted => psb_lz_is_sorted + procedure, pass(a) :: is_by_rows => psb_lz_is_by_rows + procedure, pass(a) :: is_by_cols => psb_lz_is_by_cols + procedure, pass(a) :: is_upper => psb_lz_is_upper + procedure, pass(a) :: is_lower => psb_lz_is_lower + procedure, pass(a) :: is_triangle => psb_lz_is_triangle + procedure, pass(a) :: is_unit => psb_lz_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_lz_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_lz_get_fmt + procedure, pass(a) :: sizeof => psb_lz_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_lz_set_nrows + procedure, pass(a) :: set_ncols => psb_lz_set_ncols + procedure, pass(a) :: set_dupl => psb_lz_set_dupl + procedure, pass(a) :: set_null => psb_lz_set_null + procedure, pass(a) :: set_bld => psb_lz_set_bld + procedure, pass(a) :: set_upd => psb_lz_set_upd + procedure, pass(a) :: set_asb => psb_lz_set_asb + procedure, pass(a) :: set_sorted => psb_lz_set_sorted + procedure, pass(a) :: set_upper => psb_lz_set_upper + procedure, pass(a) :: set_lower => psb_lz_set_lower + procedure, pass(a) :: set_triangle => psb_lz_set_triangle + procedure, pass(a) :: set_unit => psb_lz_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_lz_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_lz_csall + procedure, pass(a) :: free => psb_lz_free + procedure, pass(a) :: trim => psb_lz_trim + procedure, pass(a) :: csput_a => psb_lz_csput_a + procedure, pass(a) :: csput_v => psb_lz_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_lz_csgetptn + procedure, pass(a) :: csgetrow => psb_lz_csgetrow + procedure, pass(a) :: csgetblk => psb_lz_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_lz_icsgetptn + procedure, pass(a) :: icsgetrow => psb_lz_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_lz_tril + procedure, pass(a) :: triu => psb_lz_triu + procedure, pass(a) :: m_csclip => psb_lz_csclip + procedure, pass(a) :: b_csclip => psb_lz_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_lz_clean_zeros + procedure, pass(a) :: reall => psb_lz_reallocate_nz + procedure, pass(a) :: get_neigh => psb_lz_get_neigh + procedure, pass(a) :: reinit => psb_lz_reinit + procedure, pass(a) :: print_i => psb_lz_sparse_print + procedure, pass(a) :: print_n => psb_lz_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_lz_mold + procedure, pass(a) :: asb => psb_lz_asb + procedure, pass(a) :: transp_1mat => psb_lz_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lz_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_lz_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lz_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => lz_mat_sync + procedure, pass(a) :: is_host => lz_mat_is_host + procedure, pass(a) :: is_dev => lz_mat_is_dev + procedure, pass(a) :: is_sync => lz_mat_is_sync + procedure, pass(a) :: set_host => lz_mat_set_host + procedure, pass(a) :: set_dev => lz_mat_set_dev + procedure, pass(a) :: set_sync => lz_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_lz_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_lz_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_lz_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_lz_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_lz_cscnv + procedure, pass(a) :: cscnv_ip => psb_lz_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_lz_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_lzspmat_clone + + ! Computational routines + procedure, pass(a) :: get_diag => psb_lz_get_diag + procedure, pass(a) :: scals => psb_lz_scals + procedure, pass(a) :: scalv => psb_lz_scal + generic, public :: scal => scals, scalv + + end type psb_lzspmat_type + + private :: psb_lz_get_nrows, psb_lz_get_ncols, & + & psb_lz_get_nzeros, psb_lz_get_size, & + & psb_lz_get_dupl, psb_lz_is_null, psb_lz_is_bld, & + & psb_lz_is_upd, psb_lz_is_asb, psb_lz_is_sorted, & + & psb_lz_is_by_rows, psb_lz_is_by_cols, psb_lz_is_upper, & + & psb_lz_is_lower, psb_lz_is_triangle, psb_lz_get_nz_row, & + & lz_mat_sync, lz_mat_is_host, lz_mat_is_dev, & + & lz_mat_is_sync, lz_mat_set_host, lz_mat_set_dev,& + & lz_mat_set_sync + + + + class(psb_lz_base_sparse_mat), allocatable, target, & + & save, private :: psb_lz_base_mat_default + + interface psb_set_mat_default + module procedure psb_lz_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_lz_get_mat_default + end interface + + ! == =================================== ! ! @@ -271,7 +420,7 @@ module psb_z_mat_mod interface subroutine psb_z_set_dupl(n,a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_z_set_dupl @@ -279,35 +428,35 @@ module psb_z_mat_mod interface subroutine psb_z_set_null(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_null end interface interface subroutine psb_z_set_bld(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_bld end interface interface subroutine psb_z_set_upd(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_upd end interface interface subroutine psb_z_set_asb(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_asb end interface interface subroutine psb_z_set_sorted(a,val) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_sorted @@ -315,7 +464,7 @@ module psb_z_mat_mod interface subroutine psb_z_set_triangle(a,val) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_triangle @@ -323,7 +472,7 @@ module psb_z_mat_mod interface subroutine psb_z_set_unit(a,val) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_unit @@ -331,7 +480,7 @@ module psb_z_mat_mod interface subroutine psb_z_set_lower(a,val) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_lower @@ -339,7 +488,7 @@ module psb_z_mat_mod interface subroutine psb_z_set_upper(a,val) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_upper @@ -347,7 +496,7 @@ module psb_z_mat_mod interface subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type integer(psb_ipk_), intent(in) :: iout class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -358,7 +507,7 @@ module psb_z_mat_mod interface subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type character(len=*), intent(in) :: fname class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -369,7 +518,7 @@ module psb_z_mat_mod interface subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_), intent(out) :: n @@ -381,7 +530,7 @@ module psb_z_mat_mod interface subroutine psb_z_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info @@ -391,7 +540,7 @@ module psb_z_mat_mod interface subroutine psb_z_reallocate_nz(nz,a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_reallocate_nz @@ -399,21 +548,21 @@ module psb_z_mat_mod interface subroutine psb_z_free(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_free end interface interface subroutine psb_z_trim(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_trim end interface interface subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -427,7 +576,7 @@ module psb_z_mat_mod subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) use psb_z_vect_mod, only : psb_z_vect_type use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a type(psb_z_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -440,7 +589,7 @@ module psb_z_mat_mod interface subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -456,7 +605,7 @@ module psb_z_mat_mod interface subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -473,7 +622,7 @@ module psb_z_mat_mod interface subroutine psb_z_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -488,7 +637,7 @@ module psb_z_mat_mod interface subroutine psb_z_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -501,7 +650,7 @@ module psb_z_mat_mod interface subroutine psb_z_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -515,7 +664,7 @@ module psb_z_mat_mod interface subroutine psb_z_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -527,7 +676,7 @@ module psb_z_mat_mod interface subroutine psb_z_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_coo_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_coo_sparse_mat class(psb_zspmat_type), intent(in) :: a type(psb_z_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -538,7 +687,7 @@ module psb_z_mat_mod interface subroutine psb_z_mold(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_z_mold @@ -546,7 +695,7 @@ module psb_z_mat_mod interface subroutine psb_z_asb(a,mold) - import :: psb_ipk_, psb_zspmat_type, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_z_asb @@ -554,14 +703,14 @@ module psb_z_mat_mod interface subroutine psb_z_transp_1mat(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_transp_1mat end interface interface subroutine psb_z_transp_2mat(a,b) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b end subroutine psb_z_transp_2mat @@ -569,14 +718,14 @@ module psb_z_mat_mod interface subroutine psb_z_transc_1mat(a) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_transc_1mat end interface interface subroutine psb_z_transc_2mat(a,b) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b end subroutine psb_z_transc_2mat @@ -584,7 +733,7 @@ module psb_z_mat_mod interface subroutine psb_z_reinit(a,clear) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_reinit @@ -607,7 +756,7 @@ module psb_z_mat_mod ! interface subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -620,7 +769,7 @@ module psb_z_mat_mod interface subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: iinfo integer(psb_ipk_),optional, intent(in) :: dupl @@ -632,7 +781,7 @@ module psb_z_mat_mod interface subroutine psb_z_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +795,7 @@ module psb_z_mat_mod ! interface subroutine psb_z_clip_d(a,b,info) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_),intent(out) :: info @@ -655,7 +804,7 @@ module psb_z_mat_mod interface subroutine psb_z_clip_d_ip(a,info) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_z_clip_d_ip @@ -667,7 +816,7 @@ module psb_z_mat_mod ! interface subroutine psb_z_mv_from(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_z_mv_from @@ -675,7 +824,7 @@ module psb_z_mat_mod interface subroutine psb_z_cp_from(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(out) :: a class(psb_z_base_sparse_mat), intent(in) :: b end subroutine psb_z_cp_from @@ -683,7 +832,7 @@ module psb_z_mat_mod interface subroutine psb_z_mv_to(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_z_mv_to @@ -691,7 +840,7 @@ module psb_z_mat_mod interface subroutine psb_z_cp_to(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_z_cp_to @@ -702,7 +851,7 @@ module psb_z_mat_mod ! interface psb_move_alloc subroutine psb_zspmat_type_move(a,b,info) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -711,7 +860,7 @@ module psb_z_mat_mod interface subroutine psb_zspmat_clone(a,b,info) - import :: psb_ipk_, psb_zspmat_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -736,7 +885,7 @@ module psb_z_mat_mod interface psb_csmm subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -744,7 +893,7 @@ module psb_z_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_csmm subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -753,7 +902,7 @@ module psb_z_mat_mod end subroutine psb_z_csmv subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_z_vect_mod, only : psb_z_vect_type - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta type(psb_z_vect_type), intent(inout) :: x @@ -765,7 +914,7 @@ module psb_z_mat_mod interface psb_cssm subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -774,7 +923,7 @@ module psb_z_mat_mod 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_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -784,7 +933,7 @@ module psb_z_mat_mod end subroutine psb_z_cssv subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_z_vect_mod, only : psb_z_vect_type - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta type(psb_z_vect_type), intent(inout) :: x @@ -797,7 +946,7 @@ module psb_z_mat_mod interface function psb_z_maxval(a) result(res) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_z_maxval @@ -805,7 +954,7 @@ module psb_z_mat_mod interface function psb_z_csnmi(a) result(res) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csnmi @@ -813,7 +962,7 @@ module psb_z_mat_mod interface function psb_z_csnm1(a) result(res) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csnm1 @@ -821,7 +970,7 @@ module psb_z_mat_mod interface function psb_z_rowsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -830,7 +979,7 @@ module psb_z_mat_mod interface function psb_z_arwsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -839,7 +988,7 @@ module psb_z_mat_mod interface function psb_z_colsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -848,7 +997,7 @@ module psb_z_mat_mod interface function psb_z_aclsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -857,7 +1006,7 @@ module psb_z_mat_mod interface function psb_z_get_diag(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -866,14 +1015,14 @@ module psb_z_mat_mod interface psb_scal subroutine psb_z_scal(d,a,info,side) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_z_scal subroutine psb_z_scals(d,a,info) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -881,51 +1030,12 @@ module psb_z_mat_mod end interface -contains - - - - subroutine psb_z_set_mat_default(a) - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - - if (allocated(psb_z_base_mat_default)) then - deallocate(psb_z_base_mat_default) - end if - allocate(psb_z_base_mat_default, mold=a) - - end subroutine psb_z_set_mat_default - - function psb_z_get_mat_default(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - class(psb_z_base_sparse_mat), pointer :: res - - res => psb_z_get_base_mat_default() - - end function psb_z_get_mat_default - - - function psb_z_get_base_mat_default() result(res) - implicit none - class(psb_z_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_z_base_mat_default)) then - allocate(psb_z_csr_sparse_mat :: psb_z_base_mat_default) - end if - - res => psb_z_base_mat_default - - end function psb_z_get_base_mat_default - - - - ! == =================================== ! ! ! - ! Getters + ! Setters + ! ! ! ! @@ -933,29 +1043,558 @@ contains ! ! == =================================== + + interface + subroutine psb_lz_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_lz_set_nrows + end interface - function psb_z_sizeof(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_epk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_z_sizeof + interface + subroutine psb_lz_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_lz_set_ncols + end interface + + interface + subroutine psb_lz_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_lz_set_dupl + end interface + + interface + subroutine psb_lz_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_null + end interface + + interface + subroutine psb_lz_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_bld + end interface + + interface + subroutine psb_lz_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_upd + end interface + + interface + subroutine psb_lz_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_asb + end interface + + interface + subroutine psb_lz_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_sorted + end interface + + interface + subroutine psb_lz_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_triangle + end interface + + interface + subroutine psb_lz_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_unit + end interface + + interface + subroutine psb_lz_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_lower + end interface + + interface + subroutine psb_lz_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_upper + end interface + + interface + subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_sparse_print + end interface + interface + subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + character(len=*), intent(in) :: fname + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_n_sparse_print + end interface + + interface + subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_lz_get_neigh + end interface + + interface + subroutine psb_lz_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_csall + end interface + + interface + subroutine psb_lz_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_reallocate_nz + end interface + + interface + subroutine psb_lz_free(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_free + end interface + + interface + subroutine psb_lz_trim(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_trim + end interface + + interface + subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csput_a + end interface - function psb_z_get_fmt(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - character(len=5) :: res + + interface + subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_vect_mod, only : psb_z_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + type(psb_z_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csput_v + end interface + + interface + subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csgetptn + end interface + + interface + subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csgetrow + end interface + + interface + subroutine psb_lz_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csgetblk + end interface + + interface + subroutine psb_lz_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: u + end subroutine psb_lz_tril + end interface + + interface + subroutine psb_lz_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: l + end subroutine psb_lz_triu + end interface - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' + + interface + subroutine psb_lz_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csclip + end interface + + interface + subroutine psb_lz_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_coo_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + type(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_b_csclip + end interface + + interface + subroutine psb_lz_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_lz_mold + end interface + + interface + subroutine psb_lz_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_lz_asb + end interface + + interface + subroutine psb_lz_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_transp_1mat + end interface + + interface + subroutine psb_lz_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_lz_transp_2mat + end interface + + interface + subroutine psb_lz_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_transc_1mat + end interface + + interface + subroutine psb_lz_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_lz_transc_2mat + end interface + + interface + subroutine psb_lz_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lz_cscnv + end interface + + + interface + subroutine psb_lz_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lz_cscnv_ip + end interface + + + interface + subroutine psb_lz_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_lz_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_lz_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_mv_from + end interface + + interface + subroutine psb_lz_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(out) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + end subroutine psb_lz_cp_from + end interface + + interface + subroutine psb_lz_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_mv_to + end interface + + interface + subroutine psb_lz_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_cp_to + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_lzspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzspmat_type_move + end interface + + interface + subroutine psb_lzspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzspmat_clone + end interface + + + + interface + function psb_lz_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_get_diag + end interface + + interface psb_scal + subroutine psb_lz_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_scal + subroutine psb_lz_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_scals + end interface + + + + + +contains + + + + subroutine psb_z_set_mat_default(a) + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + + if (allocated(psb_z_base_mat_default)) then + deallocate(psb_z_base_mat_default) + end if + allocate(psb_z_base_mat_default, mold=a) + + end subroutine psb_z_set_mat_default + + function psb_z_get_mat_default(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), pointer :: res + + res => psb_z_get_base_mat_default() + + end function psb_z_get_mat_default + + + function psb_z_get_base_mat_default() result(res) + implicit none + class(psb_z_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_z_base_mat_default)) then + allocate(psb_z_csr_sparse_mat :: psb_z_base_mat_default) + end if + + res => psb_z_base_mat_default + + end function psb_z_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_z_sizeof(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_z_sizeof + + + function psb_z_get_fmt(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' end if end function psb_z_get_fmt @@ -1376,4 +2015,502 @@ contains end subroutine psb_z_lcsgetrow #endif + + ! + ! lz methods + ! + + + subroutine psb_lz_set_mat_default(a) + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + + if (allocated(psb_lz_base_mat_default)) then + deallocate(psb_lz_base_mat_default) + end if + allocate(psb_lz_base_mat_default, mold=a) + + end subroutine psb_lz_set_mat_default + + function psb_lz_get_mat_default(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), pointer :: res + + res => psb_lz_get_base_mat_default() + + end function psb_lz_get_mat_default + + + function psb_lz_get_base_mat_default() result(res) + implicit none + class(psb_lz_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_lz_base_mat_default)) then + allocate(psb_lz_csr_sparse_mat :: psb_lz_base_mat_default) + end if + + res => psb_lz_base_mat_default + + end function psb_lz_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_lz_sizeof(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_lz_sizeof + + + function psb_lz_get_fmt(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_lz_get_fmt + + + function psb_lz_get_dupl(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_lz_get_dupl + + function psb_lz_get_nrows(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_lz_get_nrows + + function psb_lz_get_ncols(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_lz_get_ncols + + function psb_lz_is_triangle(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_lz_is_triangle + + function psb_lz_is_unit(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_lz_is_unit + + function psb_lz_is_upper(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_lz_is_upper + + function psb_lz_is_lower(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_lz_is_lower + + function psb_lz_is_null(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_lz_is_null + + function psb_lz_is_bld(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_lz_is_bld + + function psb_lz_is_upd(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_lz_is_upd + + function psb_lz_is_asb(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_lz_is_asb + + function psb_lz_is_sorted(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_lz_is_sorted + + function psb_lz_is_by_rows(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_lz_is_by_rows + + function psb_lz_is_by_cols(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_lz_is_by_cols + + + ! + subroutine lz_mat_sync(a) + implicit none + class(psb_lzspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine lz_mat_sync + + ! + subroutine lz_mat_set_host(a) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine lz_mat_set_host + + + ! + subroutine lz_mat_set_dev(a) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine lz_mat_set_dev + + ! + subroutine lz_mat_set_sync(a) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine lz_mat_set_sync + + ! + function lz_mat_is_dev(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function lz_mat_is_dev + + ! + function lz_mat_is_host(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function lz_mat_is_host + + ! + function lz_mat_is_sync(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function lz_mat_is_sync + + + function psb_lz_is_repeatable_updates(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_lz_is_repeatable_updates + + subroutine psb_lz_set_repeatable_updates(a,val) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_lz_set_repeatable_updates + + + function psb_lz_get_nzeros(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_lz_get_nzeros + + function psb_lz_get_size(a) result(res) + + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_lz_get_size + + + function psb_lz_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_lz_get_nz_row + + subroutine psb_lz_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_lzspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_lz_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_lz_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lz_icsgetptn + + subroutine psb_lz_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lz_icsgetrow +#endif + end module psb_z_mat_mod diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 4fb59411..7a1b18e7 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2435,4 +2433,1903 @@ subroutine psb_c_scals(d,a,info) end subroutine psb_c_scals +subroutine psb_lc_set_nrows(m,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_nrows + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_nrows + + +subroutine psb_lc_set_ncols(n,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_ncols + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_lc_set_dupl(n,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_dupl + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_lc_set_null(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_null + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_null + + +subroutine psb_lc_set_bld(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_bld + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_bld + + +subroutine psb_lc_set_upd(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_upd + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lc_set_upd + + +subroutine psb_lc_set_asb(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_asb + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_asb + + +subroutine psb_lc_set_sorted(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_sorted + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_sorted + + +subroutine psb_lc_set_triangle(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_triangle + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_triangle + + +subroutine psb_lc_set_unit(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_unit + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_unit + + +subroutine psb_lc_set_lower(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_lower + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_lower + + +subroutine psb_lc_set_upper(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_upper + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_c_mat_mod, psb_protect_name => psb_lc_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_sparse_print + + +subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_c_mat_mod, psb_protect_name => psb_lc_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_n_sparse_print + + +subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) + use psb_c_mat_mod, psb_protect_name => psb_lc_get_neigh + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_get_neigh + + + +subroutine psb_lc_csall(nr,nc,a,info,nz) + use psb_c_mat_mod, psb_protect_name => psb_lc_csall + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csall + + +subroutine psb_lc_reallocate_nz(nz,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_reallocate_nz + + +subroutine psb_lc_free(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_free + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_lc_free + + +subroutine psb_lc_trim(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_trim + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_trim + + + +subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_mat_mod, psb_protect_name => psb_lc_csput_a + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csput_a + +subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_mat_mod, psb_protect_name => psb_lc_csput_v + use psb_c_base_mat_mod + use psb_c_vect_mod, only : psb_c_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + type(psb_c_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csput_v + + +subroutine psb_lc_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_lc_csgetptn + implicit none + + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csgetptn + + +subroutine psb_lc_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_lc_csgetrow + implicit none + + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csgetrow + + + + +subroutine psb_lc_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_lc_csgetblk + implicit none + + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_lc_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csgetblk + + +subroutine psb_lc_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_tril + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lc_tril + +subroutine psb_lc_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_triu + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lc_triu + + +subroutine psb_lc_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_lc_csclip + implicit none + + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csclip + + +subroutine psb_lc_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_lc_b_csclip + implicit none + + class(psb_lcspmat_type), intent(in) :: a + type(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_b_csclip + + + + +subroutine psb_lc_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_lc_cscnv + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lc_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cscnv + + + +subroutine psb_lc_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv_ip + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lc_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cscnv_ip + + + +subroutine psb_lc_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv_base + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_lc_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cscnv_base + + + +!!$subroutine psb_lc_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_c_base_mat_mod +!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d +!!$ implicit none +!!$ +!!$ class(psb_lcspmat_type), intent(in) :: a +!!$ class(psb_lcspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lc_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_lc_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_c_base_mat_mod +!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_lcspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lc_clip_d_ip +!!$ + +subroutine psb_lc_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_lc_mv_from + + +subroutine psb_lc_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from + implicit none + class(psb_lcspmat_type), intent(out) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lc_cp_from + + +subroutine psb_lc_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_lc_mv_to + + +subroutine psb_lc_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_lc_cp_to + +subroutine psb_lc_mold(a,b) + use psb_c_mat_mod, psb_protect_name => psb_lc_mold + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_lc_mold + +subroutine psb_lcspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lcspmat_type_move + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_lcspmat_type_move + + +subroutine psb_lcspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lcspmat_clone + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcspmat_clone + + +subroutine psb_lc_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transp_1mat + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transp_1mat + + + +subroutine psb_lc_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transp_2mat + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transp_2mat + + +subroutine psb_lc_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transc_1mat + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transc_1mat + + + +subroutine psb_lc_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transc_2mat + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transc_2mat + + +subroutine psb_lc_asb(a,mold) + use psb_c_mat_mod, psb_protect_name => psb_lc_asb + use psb_error_mod + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), optional, intent(in) :: mold + class(psb_lc_base_sparse_mat), allocatable :: tmp + class(psb_lc_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lc_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_lc_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_asb + +subroutine psb_lc_reinit(a,clear) + use psb_c_mat_mod, psb_protect_name => psb_lc_reinit + use psb_error_mod + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_reinit + + + + +function psb_lc_get_diag(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_get_diag + + +subroutine psb_lc_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_scal + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_scal + + +subroutine psb_lc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_scals + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_scals + + diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 3628635e..a72dbb77 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2435,4 +2433,1903 @@ subroutine psb_d_scals(d,a,info) end subroutine psb_d_scals +subroutine psb_ld_set_nrows(m,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_nrows + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_nrows + + +subroutine psb_ld_set_ncols(n,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_ncols + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_ld_set_dupl(n,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_dupl + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_ld_set_null(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_null + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_null + + +subroutine psb_ld_set_bld(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_bld + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_bld + + +subroutine psb_ld_set_upd(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_upd + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ld_set_upd + + +subroutine psb_ld_set_asb(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_asb + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_asb + + +subroutine psb_ld_set_sorted(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_sorted + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_sorted + + +subroutine psb_ld_set_triangle(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_triangle + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_triangle + + +subroutine psb_ld_set_unit(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_unit + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_unit + + +subroutine psb_ld_set_lower(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_lower + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_lower + + +subroutine psb_ld_set_upper(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_upper + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_ld_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_sparse_print + + +subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_ld_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_n_sparse_print + + +subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) + use psb_d_mat_mod, psb_protect_name => psb_ld_get_neigh + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_get_neigh + + + +subroutine psb_ld_csall(nr,nc,a,info,nz) + use psb_d_mat_mod, psb_protect_name => psb_ld_csall + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csall + + +subroutine psb_ld_reallocate_nz(nz,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_reallocate_nz + + +subroutine psb_ld_free(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_free + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_ld_free + + +subroutine psb_ld_trim(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_trim + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_trim + + + +subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_mat_mod, psb_protect_name => psb_ld_csput_a + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csput_a + +subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_mat_mod, psb_protect_name => psb_ld_csput_v + use psb_d_base_mat_mod + use psb_d_vect_mod, only : psb_d_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + type(psb_d_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csput_v + + +subroutine psb_ld_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_ld_csgetptn + implicit none + + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csgetptn + + +subroutine psb_ld_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_ld_csgetrow + implicit none + + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csgetrow + + + + +subroutine psb_ld_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_ld_csgetblk + implicit none + + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_ld_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csgetblk + + +subroutine psb_ld_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_tril + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ld_tril + +subroutine psb_ld_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_triu + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ld_triu + + +subroutine psb_ld_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_ld_csclip + implicit none + + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csclip + + +subroutine psb_ld_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_ld_b_csclip + implicit none + + class(psb_ldspmat_type), intent(in) :: a + type(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_b_csclip + + + + +subroutine psb_ld_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_ld_cscnv + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ld_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cscnv + + + +subroutine psb_ld_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv_ip + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ld_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cscnv_ip + + + +subroutine psb_ld_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv_base + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_ld_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cscnv_base + + + +!!$subroutine psb_ld_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_d_base_mat_mod +!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d +!!$ implicit none +!!$ +!!$ class(psb_ldspmat_type), intent(in) :: a +!!$ class(psb_ldspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ld_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_ld_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_d_base_mat_mod +!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_ldspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ld_clip_d_ip +!!$ + +subroutine psb_ld_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_ld_mv_from + + +subroutine psb_ld_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from + implicit none + class(psb_ldspmat_type), intent(out) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ld_cp_from + + +subroutine psb_ld_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_ld_mv_to + + +subroutine psb_ld_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_ld_cp_to + +subroutine psb_ld_mold(a,b) + use psb_d_mat_mod, psb_protect_name => psb_ld_mold + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_ld_mold + +subroutine psb_ldspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ldspmat_type_move + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_ldspmat_type_move + + +subroutine psb_ldspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ldspmat_clone + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldspmat_clone + + +subroutine psb_ld_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transp_1mat + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transp_1mat + + + +subroutine psb_ld_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transp_2mat + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transp_2mat + + +subroutine psb_ld_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transc_1mat + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transc_1mat + + + +subroutine psb_ld_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transc_2mat + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transc_2mat + + +subroutine psb_ld_asb(a,mold) + use psb_d_mat_mod, psb_protect_name => psb_ld_asb + use psb_error_mod + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), optional, intent(in) :: mold + class(psb_ld_base_sparse_mat), allocatable :: tmp + class(psb_ld_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ld_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_ld_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_asb + +subroutine psb_ld_reinit(a,clear) + use psb_d_mat_mod, psb_protect_name => psb_ld_reinit + use psb_error_mod + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_reinit + + + + +function psb_ld_get_diag(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_get_diag + + +subroutine psb_ld_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_scal + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_scal + + +subroutine psb_ld_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_scals + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_scals + + diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 2f14018c..5907f9c0 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2435,4 +2433,1903 @@ subroutine psb_s_scals(d,a,info) end subroutine psb_s_scals +subroutine psb_ls_set_nrows(m,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_nrows + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_nrows + + +subroutine psb_ls_set_ncols(n,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_ncols + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_ls_set_dupl(n,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_dupl + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_ls_set_null(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_null + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_null + + +subroutine psb_ls_set_bld(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_bld + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_bld + + +subroutine psb_ls_set_upd(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_upd + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ls_set_upd + + +subroutine psb_ls_set_asb(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_asb + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_asb + + +subroutine psb_ls_set_sorted(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_sorted + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_sorted + + +subroutine psb_ls_set_triangle(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_triangle + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_triangle + + +subroutine psb_ls_set_unit(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_unit + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_unit + + +subroutine psb_ls_set_lower(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_lower + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_lower + + +subroutine psb_ls_set_upper(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_upper + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_s_mat_mod, psb_protect_name => psb_ls_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_sparse_print + + +subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_s_mat_mod, psb_protect_name => psb_ls_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_n_sparse_print + + +subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) + use psb_s_mat_mod, psb_protect_name => psb_ls_get_neigh + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_get_neigh + + + +subroutine psb_ls_csall(nr,nc,a,info,nz) + use psb_s_mat_mod, psb_protect_name => psb_ls_csall + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csall + + +subroutine psb_ls_reallocate_nz(nz,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_reallocate_nz + + +subroutine psb_ls_free(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_free + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_ls_free + + +subroutine psb_ls_trim(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_trim + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_trim + + + +subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_mat_mod, psb_protect_name => psb_ls_csput_a + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csput_a + +subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_mat_mod, psb_protect_name => psb_ls_csput_v + use psb_s_base_mat_mod + use psb_s_vect_mod, only : psb_s_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + type(psb_s_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csput_v + + +subroutine psb_ls_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_ls_csgetptn + implicit none + + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csgetptn + + +subroutine psb_ls_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_ls_csgetrow + implicit none + + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csgetrow + + + + +subroutine psb_ls_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_ls_csgetblk + implicit none + + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_ls_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csgetblk + + +subroutine psb_ls_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_tril + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ls_tril + +subroutine psb_ls_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_triu + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ls_triu + + +subroutine psb_ls_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_ls_csclip + implicit none + + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csclip + + +subroutine psb_ls_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_ls_b_csclip + implicit none + + class(psb_lsspmat_type), intent(in) :: a + type(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_b_csclip + + + + +subroutine psb_ls_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_ls_cscnv + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ls_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cscnv + + + +subroutine psb_ls_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv_ip + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ls_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cscnv_ip + + + +subroutine psb_ls_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv_base + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_ls_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cscnv_base + + + +!!$subroutine psb_ls_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_s_base_mat_mod +!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d +!!$ implicit none +!!$ +!!$ class(psb_lsspmat_type), intent(in) :: a +!!$ class(psb_lsspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ls_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_ls_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_s_base_mat_mod +!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_lsspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ls_clip_d_ip +!!$ + +subroutine psb_ls_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_ls_mv_from + + +subroutine psb_ls_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from + implicit none + class(psb_lsspmat_type), intent(out) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ls_cp_from + + +subroutine psb_ls_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_ls_mv_to + + +subroutine psb_ls_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_ls_cp_to + +subroutine psb_ls_mold(a,b) + use psb_s_mat_mod, psb_protect_name => psb_ls_mold + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_ls_mold + +subroutine psb_lsspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_lsspmat_type_move + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_lsspmat_type_move + + +subroutine psb_lsspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_lsspmat_clone + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lsspmat_clone + + +subroutine psb_ls_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transp_1mat + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transp_1mat + + + +subroutine psb_ls_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transp_2mat + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transp_2mat + + +subroutine psb_ls_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transc_1mat + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transc_1mat + + + +subroutine psb_ls_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transc_2mat + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transc_2mat + + +subroutine psb_ls_asb(a,mold) + use psb_s_mat_mod, psb_protect_name => psb_ls_asb + use psb_error_mod + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), optional, intent(in) :: mold + class(psb_ls_base_sparse_mat), allocatable :: tmp + class(psb_ls_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ls_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_ls_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_asb + +subroutine psb_ls_reinit(a,clear) + use psb_s_mat_mod, psb_protect_name => psb_ls_reinit + use psb_error_mod + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_reinit + + + + +function psb_ls_get_diag(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_get_diag + + +subroutine psb_ls_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_scal + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_scal + + +subroutine psb_ls_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_scals + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_scals + + diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index 15df2efa..37e6db48 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2435,4 +2433,1903 @@ subroutine psb_z_scals(d,a,info) end subroutine psb_z_scals +subroutine psb_lz_set_nrows(m,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_nrows + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_nrows + + +subroutine psb_lz_set_ncols(n,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_ncols + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_lz_set_dupl(n,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_dupl + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_lz_set_null(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_null + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_null + + +subroutine psb_lz_set_bld(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_bld + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_bld + + +subroutine psb_lz_set_upd(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_upd + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lz_set_upd + + +subroutine psb_lz_set_asb(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_asb + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_asb + + +subroutine psb_lz_set_sorted(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_sorted + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_sorted + + +subroutine psb_lz_set_triangle(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_triangle + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_triangle + + +subroutine psb_lz_set_unit(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_unit + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_unit + + +subroutine psb_lz_set_lower(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_lower + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_lower + + +subroutine psb_lz_set_upper(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_upper + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_z_mat_mod, psb_protect_name => psb_lz_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_sparse_print + + +subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_z_mat_mod, psb_protect_name => psb_lz_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_n_sparse_print + + +subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) + use psb_z_mat_mod, psb_protect_name => psb_lz_get_neigh + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_get_neigh + + + +subroutine psb_lz_csall(nr,nc,a,info,nz) + use psb_z_mat_mod, psb_protect_name => psb_lz_csall + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csall + + +subroutine psb_lz_reallocate_nz(nz,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_reallocate_nz + + +subroutine psb_lz_free(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_free + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_lz_free + + +subroutine psb_lz_trim(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_trim + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: 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 = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_trim + + + +subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_mat_mod, psb_protect_name => psb_lz_csput_a + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csput_a + +subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_mat_mod, psb_protect_name => psb_lz_csput_v + use psb_z_base_mat_mod + use psb_z_vect_mod, only : psb_z_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + type(psb_z_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csput_v + + +subroutine psb_lz_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_lz_csgetptn + implicit none + + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csgetptn + + +subroutine psb_lz_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_lz_csgetrow + implicit none + + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csgetrow + + + + +subroutine psb_lz_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_lz_csgetblk + implicit none + + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_lz_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csgetblk + + +subroutine psb_lz_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_tril + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lz_tril + +subroutine psb_lz_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_triu + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lz_triu + + +subroutine psb_lz_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_lz_csclip + implicit none + + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csclip + + +subroutine psb_lz_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_lz_b_csclip + implicit none + + class(psb_lzspmat_type), intent(in) :: a + type(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_b_csclip + + + + +subroutine psb_lz_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_lz_cscnv + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lz_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cscnv + + + +subroutine psb_lz_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv_ip + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lz_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cscnv_ip + + + +subroutine psb_lz_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv_base + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_lz_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cscnv_base + + + +!!$subroutine psb_lz_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_z_base_mat_mod +!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d +!!$ implicit none +!!$ +!!$ class(psb_lzspmat_type), intent(in) :: a +!!$ class(psb_lzspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lz_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_lz_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_z_base_mat_mod +!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_lzspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lz_clip_d_ip +!!$ + +subroutine psb_lz_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_lz_mv_from + + +subroutine psb_lz_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from + implicit none + class(psb_lzspmat_type), intent(out) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lz_cp_from + + +subroutine psb_lz_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_lz_mv_to + + +subroutine psb_lz_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_lz_cp_to + +subroutine psb_lz_mold(a,b) + use psb_z_mat_mod, psb_protect_name => psb_lz_mold + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_lz_mold + +subroutine psb_lzspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lzspmat_type_move + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_lzspmat_type_move + + +subroutine psb_lzspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lzspmat_clone + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lzspmat_clone + + +subroutine psb_lz_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transp_1mat + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transp_1mat + + + +subroutine psb_lz_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transp_2mat + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transp_2mat + + +subroutine psb_lz_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transc_1mat + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transc_1mat + + + +subroutine psb_lz_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transc_2mat + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transc_2mat + + +subroutine psb_lz_asb(a,mold) + use psb_z_mat_mod, psb_protect_name => psb_lz_asb + use psb_error_mod + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), optional, intent(in) :: mold + class(psb_lz_base_sparse_mat), allocatable :: tmp + class(psb_lz_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lz_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_lz_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_asb + +subroutine psb_lz_reinit(a,clear) + use psb_z_mat_mod, psb_protect_name => psb_lz_reinit + use psb_error_mod + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_reinit + + + + +function psb_lz_get_diag(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_get_diag + + +subroutine psb_lz_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_scal + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_scal + + +subroutine psb_lz_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_scals + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_scals + +